PSBML1 ;BIRMINGHAM/VRN-BCMA API TO IPM FOR EXPIRING ONE-TIME ORDERS ;Mar 2004
;;3.0;BAR CODE MED ADMIN;**3**;Mar 2004
;
; Reference/IA
; EN^PSJBCMA3/3320
; ENE^PSJBCMA4/3416
; ENR^PSJBCMA4/3416
; ^XUSEC/10076
;
EXPIRE ;
S PSBFLAG=0,(X,Y)=""
F S X=$O(^PSB(53.79,"AOIP",PSBREC(0),PSBREC(4),X),-1) Q:X="" D
.F S Y=$O(^PSB(53.79,"AOIP",PSBREC(0),PSBREC(4),X,Y),-1) Q:'Y D
..I $D(^PSB(53.79,Y,.3)),$G(^PSB(53.79,Y,.3,1,0))["Manual" S PSBFLAG=1
..D:('PSBFLAG)&($P(^PSB(53.79,Y,0),U,9)="G") ENE^PSJBCMA4(PSBREC(0),PSBREC(1)) S (X,Y)=0
Q
;
S PSBIEN="+1,"_PSBIEN_","
D VAL^PSBML(53.793,PSBIEN,.01,PSBREC(0))
S PSBFDA(53.793,PSBIEN,.02)=DUZ
S PSBFDA(53.793,PSBIEN,.03)=PSBNOW
D FILEIT^PSBML
Q
;
PRN ;
S PSBIEN=PSBIEN_","
D VAL^PSBML(53.79,PSBIEN,.22,PSBREC(0))
D FILEIT^PSBML
Q
UPDATE ;
S PSBIEN=PSBIEN_","
I "^G^N^H^R^RM^S^C^I^"[U_PSBREC(0)_U D
.D VAL^PSBML(53.79,PSBIEN,.06,PSBNOW)
.D VAL^PSBML(53.79,PSBIEN,.07,"`"_DUZ)
.D VAL^PSBML(53.79,PSBIEN,.09,PSBREC(0))
.I $D(PSBREC(3)),PSBREC(3)]"" D VAL^PSBML(53.79,PSBIEN,.26,PSBREC(3))
D:PSBREC(1)]""
.I (PSBREC(0)="N"),($$GET1^DIQ(53.79,+PSBIEN,.09,"I")="G") S PSBREC(1)="Not Given: "_PSBREC(1)
.I ((PSBREC(0)="N")!(PSBREC(0)="G")),($$GET1^DIQ(53.79,+PSBIEN,.09,"I")="RM") S PSBREC(1)="Undo Remove: "_PSBREC(1)
.S:PSBREC(0)="H" PSBREC(1)="Held: "_PSBREC(1)
.S:PSBREC(0)="R" PSBREC(1)="Refused: "_PSBREC(1)
.S:PSBREC(0)="RM" PSBREC(1)="Removed: "_PSBREC(1)
.D VAL^PSBML(53.793,"+2,"_PSBIEN,.01,PSBREC(1))
.D VAL^PSBML(53.793,"+2,"_PSBIEN,.02,"`"_DUZ)
.D VAL^PSBML(53.793,"+2,"_PSBIEN,.03,PSBNOW)
S PSBXDFN=$$GET1^DIQ(53.79,PSBIEN,.01,"I")
I ($$GET1^DIQ(53.79,+PSBIEN,.09,"I")="RM"),((PSBREC(0)="N")!(PSBREC(0)="G")) D
.I '(($D(^XUSEC("PSB MANAGER",DUZ)))!($$GET1^DIQ(53.79,+PSBIEN,.07,"I")=DUZ)) S RESULTS(0)="-1^Verify PSB MANAGER allocation" Q
.S PSBXPTCH=1,PSBYY="",PSBGIVEN=0 F S PSBYY=$O(^PSB(53.79,+PSBIEN,.9,PSBYY),-1) Q:'PSBYY Q:(+$G(RESULTS(0))<0) Q:PSBGIVEN S PSBXDAT=$G(^(PSBYY,0)) D
..I PSBXDAT["Set to 'GIVEN'" D
...S PSBXORN=$$GET1^DIQ(53.79,+PSBIEN,.11,"I")
...F PSBYX=(PSBYY-2):-1:0 Q:PSBYX<1 I ^PSB(53.79,+PSBIEN,.9,PSBYX,0)["ACTION DATE/TIME Set to" S PSBXDATE=$P(^PSB(53.79,+PSBIEN,.9,PSBYX,0),"'",2),X=$P(PSBXDATE,"@"),%DT="" D ^%DT S PSBXDATE=Y_"."_$TR($P(PSBXDATE,"@",2),":") Q
...S PSBXDT=PSBXDATE F S PSBXDT=$O(^PSB(53.79,"AORDX",PSBXDFN,PSBXORN,PSBXDT)) Q:PSBXDT="" D Q:+$G(RESULTS(0))<0
....S PSBYZ="" F S PSBYZ=$O(^PSB(53.79,"AORDX",PSBXDFN,PSBXORN,PSBXDT,PSBYZ)) Q:'PSBYZ I $$GET1^DIQ(53.79,PSBYZ,.09,"I")="G" S RESULTS(0)="-1^Cannot UNDO! Order has GIVEN patch" Q
...I '(+$G(RESULTS(0))<0) D S PSBGIVEN=1
....D VAL^PSBML(53.79,PSBIEN,.06,PSBXDATE),VAL^PSBML(53.79,PSBIEN,.07,"`"_$P(PSBXDAT,U,2)),VAL^PSBML(53.79,PSBIEN,.09,"G")
..D:('(+$G(RESULTS(0))<0))&('PSBGIVEN)&($G(PSBXPTCH))&(PSBYY'>1)
...S PSBXDATE=$P(^PSB(53.79,+PSBIEN,.9,PSBYY,0),"'",2),X=$P(PSBXDATE,"@"),%DT="" D ^%DT S PSBXDATE=Y_"."_$TR($P(PSBXDATE,"@",2),":")
...D VAL^PSBML(53.79,PSBIEN,.06,PSBXDATE),VAL^PSBML(53.79,PSBIEN,.07,"`"_$$GET1^DIQ(53.79,+PSBIEN,.07,"I")),VAL^PSBML(53.79,PSBIEN,.09,"G") S PSBGIVEN=1
;If set to not given then set dose given to 0
Q:(+$G(RESULTS(0))<0)
S:$G(PSBGIVEN) PSBREC(0)="G"
I PSBREC(0)="N",($$GET1^DIQ(53.79,PSBIEN,.09,"I")="G") D:$D(^PSB(53.79,+PSBIEN,.5,0))
.S PSBX=0 F S PSBX=$O(^PSB(53.79,$P(PSBIEN,","),.5,PSBX)) Q:'(+PSBX) S $P(^PSB(53.79,$P(PSBIEN,","),.5,PSBX,0),"^",3)=0
I $G(PSBREC(2))]"" D VAL^PSBML(53.79,PSBIEN,.16,PSBREC(2))
S PSBOLDUZ=$P(^PSB(53.79,+PSBIEN,0),U,7),PSBOLSTS=$P(^PSB(53.79,+PSBIEN,0),U,9)
I $G(PSBREC(4))]"" D ; DD/SOL/ADD
.I PSBREC(0)="G"!(PSBREC(0)="I")!(PSBREC(0)="H")!(PSBREC(0)="R")!(PSBREC(0)="M") D ; Only apply if given or infusing
..K ^PSB(53.79,+PSBIEN,.5),^PSB(53.79,+PSBIEN,.6),^PSB(53.79,+PSBIEN,.7)
..F PSBCNT=4:1 Q:'$D(PSBREC(PSBCNT)) D
...S Y=$P(PSBREC(PSBCNT),U)
...S PSBDD=$S(Y="DD":53.795,Y="ADD":53.796,Y="SOL":53.797,1:0)
...Q:'PSBDD
...S PSBIENS="+"_PSBCNT_","_PSBIEN
...D VAL^PSBML(PSBDD,PSBIENS,.01,"`"_$P(PSBREC(PSBCNT),U,2))
...D VAL^PSBML(PSBDD,PSBIENS,.02,$P(PSBREC(PSBCNT),U,3))
...D VAL^PSBML(PSBDD,PSBIENS,.03,$P(PSBREC(PSBCNT),U,4))
...D:Y="DD" VAL^PSBML(PSBDD,PSBIENS,.04,$P(PSBREC(PSBCNT),U,5))
D FILEIT^PSBML
; add audit for change of status
; tell pharmacy if change of status on pharmacy generated UID
I $P($G(RESULTS(0)),U,1)=1 D
.S PSBUID=$P(^PSB(53.79,+PSBIEN,0),U,10) I PSBUID]"",PSBUID'["WS" D
..S PSBON=$P(^PSB(53.79,+PSBIEN,.1),U,1)
..S PSBDFN=$P(^PSB(53.79,+PSBIEN,0),U,1)
..I PSBREC(0)="N" S PSBREC(0)="" D
...M PSBAR=^PSB(53.79,+PSBIEN,.9)
...S (PSBDN,X)="" F S X=$O(PSBAR(X),-1) Q:X=0!(PSBDN=1) D
....I PSBAR(X,0)["ACTION STATUS",PSBAR(X,0)["deleted",PSBAR(X,0)'["GIVEN" D
.....S PSBTS=$P($P(PSBAR(X,0),"'",2),"'",1)
.....S PSBREC(0)=$S(PSBTS="HELD":"H",PSBTS="REFUSED":"R",PSBTS="REMOVED":"RM",PSBTS="MISSING":"M",1:""),PSBDN=1
..I PSBREC(0)="" D VAL^PSBML(53.79,PSBIEN,.26,"") D CLEAN^DILF,UPDATE^DIE("","PSBFDA","PSBIEN","PSBMSG")
..D EN^PSJBCMA3(PSBDFN,+PSBON,PSBUID,PSBREC(0),PSBNOW)
I ($$GET1^DIQ(53.79,+PSBIEN,.12,"I")="O")&($$GET1^DIQ(53.79,+PSBIEN,.09,"I")="N") S PSBDFN=$$GET1^DIQ(53.79,+PSBIEN,.01,"I") D ENR^PSJBCMA4(PSBDFN,$$GET1^DIQ(53.79,+PSBIEN,.11))
I ($$GET1^DIQ(53.79,+PSBIEN,.12,"I")="O")&($$GET1^DIQ(53.79,+PSBIEN,.09,"I")="G") S PSBDFN=$$GET1^DIQ(53.79,+PSBIEN,.01,"I") D ENE^PSJBCMA4(PSBDFN,$$GET1^DIQ(53.79,+PSBIEN,.11))
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSBML1 5516 printed Oct 16, 2024@17:40:58 Page 2
PSBML1 ;BIRMINGHAM/VRN-BCMA API TO IPM FOR EXPIRING ONE-TIME ORDERS ;Mar 2004
+1 ;;3.0;BAR CODE MED ADMIN;**3**;Mar 2004
+2 ;
+3 ; Reference/IA
+4 ; EN^PSJBCMA3/3320
+5 ; ENE^PSJBCMA4/3416
+6 ; ENR^PSJBCMA4/3416
+7 ; ^XUSEC/10076
+8 ;
EXPIRE ;
+1 SET PSBFLAG=0
SET (X,Y)=""
+2 FOR
SET X=$ORDER(^PSB(53.79,"AOIP",PSBREC(0),PSBREC(4),X),-1)
if X=""
QUIT
Begin DoDot:1
+3 FOR
SET Y=$ORDER(^PSB(53.79,"AOIP",PSBREC(0),PSBREC(4),X,Y),-1)
if 'Y
QUIT
Begin DoDot:2
+4 IF $DATA(^PSB(53.79,Y,.3))
IF $GET(^PSB(53.79,Y,.3,1,0))["Manual"
SET PSBFLAG=1
+5 if ('PSBFLAG)&($PIECE(^PSB(53.79,Y,0),U,9)="G")
DO ENE^PSJBCMA4(PSBREC(0),PSBREC(1))
SET (X,Y)=0
End DoDot:2
End DoDot:1
+6 QUIT
+7 ;
+1 SET PSBIEN="+1,"_PSBIEN_","
+2 DO VAL^PSBML(53.793,PSBIEN,.01,PSBREC(0))
+3 SET PSBFDA(53.793,PSBIEN,.02)=DUZ
+4 SET PSBFDA(53.793,PSBIEN,.03)=PSBNOW
+5 DO FILEIT^PSBML
+6 QUIT
+7 ;
PRN ;
+1 SET PSBIEN=PSBIEN_","
+2 DO VAL^PSBML(53.79,PSBIEN,.22,PSBREC(0))
+3 DO FILEIT^PSBML
+4 QUIT
UPDATE ;
+1 SET PSBIEN=PSBIEN_","
+2 IF "^G^N^H^R^RM^S^C^I^"[U_PSBREC(0)_U
Begin DoDot:1
+3 DO VAL^PSBML(53.79,PSBIEN,.06,PSBNOW)
+4 DO VAL^PSBML(53.79,PSBIEN,.07,"`"_DUZ)
+5 DO VAL^PSBML(53.79,PSBIEN,.09,PSBREC(0))
+6 IF $DATA(PSBREC(3))
IF PSBREC(3)]""
DO VAL^PSBML(53.79,PSBIEN,.26,PSBREC(3))
End DoDot:1
+7 if PSBREC(1)]""
Begin DoDot:1
+8 IF (PSBREC(0)="N")
IF ($$GET1^DIQ(53.79,+PSBIEN,.09,"I")="G")
SET PSBREC(1)="Not Given: "_PSBREC(1)
+9 IF ((PSBREC(0)="N")!(PSBREC(0)="G"))
IF ($$GET1^DIQ(53.79,+PSBIEN,.09,"I")="RM")
SET PSBREC(1)="Undo Remove: "_PSBREC(1)
+10 if PSBREC(0)="H"
SET PSBREC(1)="Held: "_PSBREC(1)
+11 if PSBREC(0)="R"
SET PSBREC(1)="Refused: "_PSBREC(1)
+12 if PSBREC(0)="RM"
SET PSBREC(1)="Removed: "_PSBREC(1)
+13 DO VAL^PSBML(53.793,"+2,"_PSBIEN,.01,PSBREC(1))
+14 DO VAL^PSBML(53.793,"+2,"_PSBIEN,.02,"`"_DUZ)
+15 DO VAL^PSBML(53.793,"+2,"_PSBIEN,.03,PSBNOW)
End DoDot:1
+16 SET PSBXDFN=$$GET1^DIQ(53.79,PSBIEN,.01,"I")
+17 IF ($$GET1^DIQ(53.79,+PSBIEN,.09,"I")="RM")
IF ((PSBREC(0)="N")!(PSBREC(0)="G"))
Begin DoDot:1
+18 IF '(($DATA(^XUSEC("PSB MANAGER",DUZ)))!($$GET1^DIQ(53.79,+PSBIEN,.07,"I")=DUZ))
SET RESULTS(0)="-1^Verify PSB MANAGER allocation"
QUIT
+19 SET PSBXPTCH=1
SET PSBYY=""
SET PSBGIVEN=0
FOR
SET PSBYY=$ORDER(^PSB(53.79,+PSBIEN,.9,PSBYY),-1)
if 'PSBYY
QUIT
if (+$GET(RESULTS(0))<0)
QUIT
if PSBGIVEN
QUIT
SET PSBXDAT=$GET(^(PSBYY,0))
Begin DoDot:2
+20 IF PSBXDAT["Set to 'GIVEN'"
Begin DoDot:3
+21 SET PSBXORN=$$GET1^DIQ(53.79,+PSBIEN,.11,"I")
+22 FOR PSBYX=(PSBYY-2):-1:0
if PSBYX<1
QUIT
IF ^PSB(53.79,+PSBIEN,.9,PSBYX,0)["ACTION DATE/TIME Set to"
SET PSBXDATE=$PIECE(^PSB(53.79,+PSBIEN,.9,PSBYX,0),"'",2)
SET X=$PIECE(PSBXDATE,"@")
SET %DT=""
DO ^%DT
SET PSBXDATE=Y_"."_$TRANSLATE($PIECE(PSBXDATE,"@",2),":")
QUIT
+23 SET PSBXDT=PSBXDATE
FOR
SET PSBXDT=$ORDER(^PSB(53.79,"AORDX",PSBXDFN,PSBXORN,PSBXDT))
if PSBXDT=""
QUIT
Begin DoDot:4
+24 SET PSBYZ=""
FOR
SET PSBYZ=$ORDER(^PSB(53.79,"AORDX",PSBXDFN,PSBXORN,PSBXDT,PSBYZ))
if 'PSBYZ
QUIT
IF $$GET1^DIQ(53.79,PSBYZ,.09,"I")="G"
SET RESULTS(0)="-1^Cannot UNDO! Order has GIVEN patch"
QUIT
End DoDot:4
if +$GET(RESULTS(0))<0
QUIT
+25 IF '(+$GET(RESULTS(0))<0)
Begin DoDot:4
+26 DO VAL^PSBML(53.79,PSBIEN,.06,PSBXDATE)
DO VAL^PSBML(53.79,PSBIEN,.07,"`"_$PIECE(PSBXDAT,U,2))
DO VAL^PSBML(53.79,PSBIEN,.09,"G")
End DoDot:4
SET PSBGIVEN=1
End DoDot:3
+27 if ('(+$GET(RESULTS(0))<0))&('PSBGIVEN)&($GET(PSBXPTCH))&(PSBYY'>1)
Begin DoDot:3
+28 SET PSBXDATE=$PIECE(^PSB(53.79,+PSBIEN,.9,PSBYY,0),"'",2)
SET X=$PIECE(PSBXDATE,"@")
SET %DT=""
DO ^%DT
SET PSBXDATE=Y_"."_$TRANSLATE($PIECE(PSBXDATE,"@",2),":")
+29 DO VAL^PSBML(53.79,PSBIEN,.06,PSBXDATE)
DO VAL^PSBML(53.79,PSBIEN,.07,"`"_$$GET1^DIQ(53.79,+PSBIEN,.07,"I"))
DO VAL^PSBML(53.79,PSBIEN,.09,"G")
SET PSBGIVEN=1
End DoDot:3
End DoDot:2
End DoDot:1
+30 ;If set to not given then set dose given to 0
+31 if (+$GET(RESULTS(0))<0)
QUIT
+32 if $GET(PSBGIVEN)
SET PSBREC(0)="G"
+33 IF PSBREC(0)="N"
IF ($$GET1^DIQ(53.79,PSBIEN,.09,"I")="G")
if $DATA(^PSB(53.79,+PSBIEN,.5,0))
Begin DoDot:1
+34 SET PSBX=0
FOR
SET PSBX=$ORDER(^PSB(53.79,$PIECE(PSBIEN,","),.5,PSBX))
if '(+PSBX)
QUIT
SET $PIECE(^PSB(53.79,$PIECE(PSBIEN,","),.5,PSBX,0),"^",3)=0
End DoDot:1
+35 IF $GET(PSBREC(2))]""
DO VAL^PSBML(53.79,PSBIEN,.16,PSBREC(2))
+36 SET PSBOLDUZ=$PIECE(^PSB(53.79,+PSBIEN,0),U,7)
SET PSBOLSTS=$PIECE(^PSB(53.79,+PSBIEN,0),U,9)
+37 ; DD/SOL/ADD
IF $GET(PSBREC(4))]""
Begin DoDot:1
+38 ; Only apply if given or infusing
IF PSBREC(0)="G"!(PSBREC(0)="I")!(PSBREC(0)="H")!(PSBREC(0)="R")!(PSBREC(0)="M")
Begin DoDot:2
+39 KILL ^PSB(53.79,+PSBIEN,.5),^PSB(53.79,+PSBIEN,.6),^PSB(53.79,+PSBIEN,.7)
+40 FOR PSBCNT=4:1
if '$DATA(PSBREC(PSBCNT))
QUIT
Begin DoDot:3
+41 SET Y=$PIECE(PSBREC(PSBCNT),U)
+42 SET PSBDD=$SELECT(Y="DD":53.795,Y="ADD":53.796,Y="SOL":53.797,1:0)
+43 if 'PSBDD
QUIT
+44 SET PSBIENS="+"_PSBCNT_","_PSBIEN
+45 DO VAL^PSBML(PSBDD,PSBIENS,.01,"`"_$PIECE(PSBREC(PSBCNT),U,2))
+46 DO VAL^PSBML(PSBDD,PSBIENS,.02,$PIECE(PSBREC(PSBCNT),U,3))
+47 DO VAL^PSBML(PSBDD,PSBIENS,.03,$PIECE(PSBREC(PSBCNT),U,4))
+48 if Y="DD"
DO VAL^PSBML(PSBDD,PSBIENS,.04,$PIECE(PSBREC(PSBCNT),U,5))
End DoDot:3
End DoDot:2
End DoDot:1
+49 DO FILEIT^PSBML
+50 ; add audit for change of status
+51 ; tell pharmacy if change of status on pharmacy generated UID
+52 IF $PIECE($GET(RESULTS(0)),U,1)=1
Begin DoDot:1
+53 SET PSBUID=$PIECE(^PSB(53.79,+PSBIEN,0),U,10)
IF PSBUID]""
IF PSBUID'["WS"
Begin DoDot:2
+54 SET PSBON=$PIECE(^PSB(53.79,+PSBIEN,.1),U,1)
+55 SET PSBDFN=$PIECE(^PSB(53.79,+PSBIEN,0),U,1)
+56 IF PSBREC(0)="N"
SET PSBREC(0)=""
Begin DoDot:3
+57 MERGE PSBAR=^PSB(53.79,+PSBIEN,.9)
+58 SET (PSBDN,X)=""
FOR
SET X=$ORDER(PSBAR(X),-1)
if X=0!(PSBDN=1)
QUIT
Begin DoDot:4
+59 IF PSBAR(X,0)["ACTION STATUS"
IF PSBAR(X,0)["deleted"
IF PSBAR(X,0)'["GIVEN"
Begin DoDot:5
+60 SET PSBTS=$PIECE($PIECE(PSBAR(X,0),"'",2),"'",1)
+61 SET PSBREC(0)=$SELECT(PSBTS="HELD":"H",PSBTS="REFUSED":"R",PSBTS="REMOVED":"RM",PSBTS="MISSING":"M",1:"")
SET PSBDN=1
End DoDot:5
End DoDot:4
End DoDot:3
+62 IF PSBREC(0)=""
DO VAL^PSBML(53.79,PSBIEN,.26,"")
DO CLEAN^DILF
DO UPDATE^DIE("","PSBFDA","PSBIEN","PSBMSG")
+63 DO EN^PSJBCMA3(PSBDFN,+PSBON,PSBUID,PSBREC(0),PSBNOW)
End DoDot:2
End DoDot:1
+64 IF ($$GET1^DIQ(53.79,+PSBIEN,.12,"I")="O")&($$GET1^DIQ(53.79,+PSBIEN,.09,"I")="N")
SET PSBDFN=$$GET1^DIQ(53.79,+PSBIEN,.01,"I")
DO ENR^PSJBCMA4(PSBDFN,$$GET1^DIQ(53.79,+PSBIEN,.11))
+65 IF ($$GET1^DIQ(53.79,+PSBIEN,.12,"I")="O")&($$GET1^DIQ(53.79,+PSBIEN,.09,"I")="G")
SET PSBDFN=$$GET1^DIQ(53.79,+PSBIEN,.01,"I")
DO ENE^PSJBCMA4(PSBDFN,$$GET1^DIQ(53.79,+PSBIEN,.11))
+66 QUIT
