PSJADT2 ;BIR/RSB-UNDO AUTO DC MAIL MESSAGE ;25 Aug 98 / 9:44 AM
;;5.0; INPATIENT MEDICATIONS ;**17,27,93**;16 DEC 97
;
; Reference to ^PS(55 is supported by DBIA# 2191
; Reference to ^PSDRUG supported by DBIA# 2192
;
SENDMSG ;Send mail message when check is complete.
N NF,PSJDISP,WS,SM,CNT,CNT1,ON,LINE
K PSJ,PSJOC,PSJLINE,XMY S XMDUZ="Inpatient Medications",XMSUB="Medication Orders Automatically Reinstated",XMTEXT="PSJ(",XMY("G.PSJ-ORDERS REINSTATED@"_$G(^XMB("NETNAME")))=""
;Add additional recipients to mail message i.e. verifying Nurse, Pharmacist, etc.
I $D(PSJSENTO) D
.S PSJLOOP=""
.F S PSJLOOP=$O(PSJSENTO($J,PSJLOOP)) Q:PSJLOOP="" D
..S XMY(PSJLOOP)=""
S PSJ(1,0)="PATIENT : "_$P(^TMP("PSJUNDC",$J,DFN),"^")_" ("_$E($P(^DPT(DFN,0),"^",9),6,9)_")"
I $P(^TMP("PSJUNDC",$J,DFN),"^",2)'="" D
.S PSJ(2,0)="CURRENT WARD LOCATION: "_$P(^TMP("PSJUNDC",$J,DFN),"^",2)
E D
.S PSJ(2,0)="CURRENT WARD LOCATION: NOT FOUND"
S PSJ(3,0)="REINSTATEMENT REASON : "_$S($P(^TMP("PSJUNDC",$J,DFN),U,3)=18550:"TRANSFER DELETED",1:"DISCHARGE DELETED")
S PSJ(4,0)="THE FOLLOWING MEDICATION ORDERS WERE AUTOMATICALLY REINSTATED."
S PSJLINE=0 S ON="" F S ON=$O(^TMP("PSJUNDC",$J,DFN,ON)) Q:ON="" D
.S (SM,WS,NF,PSJDISP)=""
.I ON["U" D DSPLORDU^PSJLMUT1(DFN,ON) D
..S SM=$S('$P(^PS(55,DFN,5,+ON,0),"^",5):0,$P(^PS(55,DFN,5,+ON,0),"^",6):1,1:2)
..S PSJPWD=$P($G(^DPT(DFN,.1)),U) S PSJPWD=$O(^DIC(42,"B",PSJPWD,0)) S WS=$$WS^PSJO(PSJPWD,DFN,"^PS(55,"_DFN_",5,",ON)
..F PSJDISP=0:0 S PSJDISP=$O(^PS(55,DFN,5,+ON,1,PSJDISP)) Q:'PSJDISP D
...I $P($G(^PSDRUG(+$P($G(^PS(55,DFN,5,+ON,1,PSJDISP,0)),"^"),0)),"^",9)=1 S NF=1
..I NF!WS!SM S PSJOC(ON,PSJLINE-2)=PSJOC(ON,PSJLINE-2)_" "_$S(NF:"NF ",WS:"WS ",SM:$E("HSM",SM,3),1:"")
.I ON["V" D DSPLORDV^PSJLMUT1(DFN,ON)
S LINE=5,CNT1=0,ON="" F S ON=$O(PSJOC(ON)) Q:ON="" D
.;S PSJ(LINE,0)=" ",LINE=LINE+1,CNT=1,CNT1=CNT1+1
.S CNT=1,CNT1=CNT1+1
.S ON2="" F S ON2=$O(PSJOC(ON,ON2)) Q:ON2="" D
..S PSJ(LINE,0)=$J($S(CNT=1:CNT1,1:" "),3)_$S(CNT=0:" ",1:"")_PSJOC(ON,ON2)
..S LINE=LINE+1,CNT=0
I $D(^TMP("PSJNOTUNDC",$J,DFN)) D
.S PSJ(LINE,0)=""
.S LINE=LINE+1,PSJ(LINE,0)="********* THE FOLLOWING ORDERS WERE NOT AUTOMATICALLY RE-INSTATED *********"
.S LINE=LINE+1,PSJ(LINE,0)="******************* DUPLICATE ORDERABLE ITEMS WERE FOUND ******************"
.S PSJLINE=0 S ON="" K PSJOC F S ON=$O(^TMP("PSJNOTUNDC",$J,DFN,ON)) Q:ON="" D
..S (SM,WS,NF,PSJDISP)=""
..I ON["U" D DSPLORDU^PSJLMUT1(DFN,ON) D
...S SM=$S('$P(^PS(55,DFN,5,+ON,0),"^",5):0,$P(^PS(55,DFN,5,+ON,0),"^",6):1,1:2)
...S PSJPWD=$P($G(^DPT(DFN,.1)),U) S PSJPWD=$O(^DIC(42,"B",PSJPWD,0)) S WS=$$WS^PSJO(PSJPWD,DFN,"^PS(55,"_DFN_",5,",ON)
...F PSJDISP=0:0 S PSJDISP=$O(^PS(55,DFN,5,+ON,1,PSJDISP)) Q:'PSJDISP D
....I $P($G(^PSDRUG(+$P($G(^PS(55,DFN,5,+ON,1,PSJDISP,0)),"^"),0)),"^",9)=1 S NF=1
...I NF!WS!SM S PSJOC(ON,PSJLINE-2)=PSJOC(ON,PSJLINE-2)_" "_$S(NF:"NF ",WS:"WS ",SM:$E("HSM",SM,3),1:"")
..I ON["V" D DSPLORDV^PSJLMUT1(DFN,ON)
.S LINE=LINE+1,CNT1=0,ON="" F S ON=$O(PSJOC(ON)) Q:ON="" D
..S CNT=1,CNT1=CNT1+1
..S ON2="" F S ON2=$O(PSJOC(ON,ON2)) Q:ON2="" D
...S PSJ(LINE,0)=$J($S(CNT=1:CNT1,1:" "),3)_$S(CNT=0:" ",1:"")_PSJOC(ON,ON2)
...S LINE=LINE+1,CNT=0
D ^XMD I $D(XMZ) S DA=XMZ,DIE=3.9,DR="1.7///P;" D ^DIE
;
DONE ;
K PSJ,PSJOC,XMDUZ,XMSUB,XMTEXT,PSJLINE,^TMP("PSJUNDC",$J),^TMP("PSJNOTUNDC",$J),PSJENTO($J)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJADT2 3466 printed Sep 23, 2025@19:42:16 Page 2
PSJADT2 ;BIR/RSB-UNDO AUTO DC MAIL MESSAGE ;25 Aug 98 / 9:44 AM
+1 ;;5.0; INPATIENT MEDICATIONS ;**17,27,93**;16 DEC 97
+2 ;
+3 ; Reference to ^PS(55 is supported by DBIA# 2191
+4 ; Reference to ^PSDRUG supported by DBIA# 2192
+5 ;
SENDMSG ;Send mail message when check is complete.
+1 NEW NF,PSJDISP,WS,SM,CNT,CNT1,ON,LINE
+2 KILL PSJ,PSJOC,PSJLINE,XMY
SET XMDUZ="Inpatient Medications"
SET XMSUB="Medication Orders Automatically Reinstated"
SET XMTEXT="PSJ("
SET XMY("G.PSJ-ORDERS REINSTATED@"_$GET(^XMB("NETNAME")))=""
+3 ;Add additional recipients to mail message i.e. verifying Nurse, Pharmacist, etc.
+4 IF $DATA(PSJSENTO)
Begin DoDot:1
+5 SET PSJLOOP=""
+6 FOR
SET PSJLOOP=$ORDER(PSJSENTO($JOB,PSJLOOP))
if PSJLOOP=""
QUIT
Begin DoDot:2
+7 SET XMY(PSJLOOP)=""
End DoDot:2
End DoDot:1
+8 SET PSJ(1,0)="PATIENT : "_$PIECE(^TMP("PSJUNDC",$JOB,DFN),"^")_" ("_$EXTRACT($PIECE(^DPT(DFN,0),"^",9),6,9)_")"
+9 IF $PIECE(^TMP("PSJUNDC",$JOB,DFN),"^",2)'=""
Begin DoDot:1
+10 SET PSJ(2,0)="CURRENT WARD LOCATION: "_$PIECE(^TMP("PSJUNDC",$JOB,DFN),"^",2)
End DoDot:1
+11 IF '$TEST
Begin DoDot:1
+12 SET PSJ(2,0)="CURRENT WARD LOCATION: NOT FOUND"
End DoDot:1
+13 SET PSJ(3,0)="REINSTATEMENT REASON : "_$SELECT($PIECE(^TMP("PSJUNDC",$JOB,DFN),U,3)=18550:"TRANSFER DELETED",1:"DISCHARGE DELETED")
+14 SET PSJ(4,0)="THE FOLLOWING MEDICATION ORDERS WERE AUTOMATICALLY REINSTATED."
+15 SET PSJLINE=0
SET ON=""
FOR
SET ON=$ORDER(^TMP("PSJUNDC",$JOB,DFN,ON))
if ON=""
QUIT
Begin DoDot:1
+16 SET (SM,WS,NF,PSJDISP)=""
+17 IF ON["U"
DO DSPLORDU^PSJLMUT1(DFN,ON)
Begin DoDot:2
+18 SET SM=$SELECT('$PIECE(^PS(55,DFN,5,+ON,0),"^",5):0,$PIECE(^PS(55,DFN,5,+ON,0),"^",6):1,1:2)
+19 SET PSJPWD=$PIECE($GET(^DPT(DFN,.1)),U)
SET PSJPWD=$ORDER(^DIC(42,"B",PSJPWD,0))
SET WS=$$WS^PSJO(PSJPWD,DFN,"^PS(55,"_DFN_",5,",ON)
+20 FOR PSJDISP=0:0
SET PSJDISP=$ORDER(^PS(55,DFN,5,+ON,1,PSJDISP))
if 'PSJDISP
QUIT
Begin DoDot:3
+21 IF $PIECE($GET(^PSDRUG(+$PIECE($GET(^PS(55,DFN,5,+ON,1,PSJDISP,0)),"^"),0)),"^",9)=1
SET NF=1
End DoDot:3
+22 IF NF!WS!SM
SET PSJOC(ON,PSJLINE-2)=PSJOC(ON,PSJLINE-2)_" "_$SELECT(NF:"NF ",WS:"WS ",SM:$EXTRACT("HSM",SM,3),1:"")
End DoDot:2
+23 IF ON["V"
DO DSPLORDV^PSJLMUT1(DFN,ON)
End DoDot:1
+24 SET LINE=5
SET CNT1=0
SET ON=""
FOR
SET ON=$ORDER(PSJOC(ON))
if ON=""
QUIT
Begin DoDot:1
+25 ;S PSJ(LINE,0)=" ",LINE=LINE+1,CNT=1,CNT1=CNT1+1
+26 SET CNT=1
SET CNT1=CNT1+1
+27 SET ON2=""
FOR
SET ON2=$ORDER(PSJOC(ON,ON2))
if ON2=""
QUIT
Begin DoDot:2
+28 SET PSJ(LINE,0)=$JUSTIFY($SELECT(CNT=1:CNT1,1:" "),3)_$SELECT(CNT=0:" ",1:"")_PSJOC(ON,ON2)
+29 SET LINE=LINE+1
SET CNT=0
End DoDot:2
End DoDot:1
+30 IF $DATA(^TMP("PSJNOTUNDC",$JOB,DFN))
Begin DoDot:1
+31 SET PSJ(LINE,0)=""
+32 SET LINE=LINE+1
SET PSJ(LINE,0)="********* THE FOLLOWING ORDERS WERE NOT AUTOMATICALLY RE-INSTATED *********"
+33 SET LINE=LINE+1
SET PSJ(LINE,0)="******************* DUPLICATE ORDERABLE ITEMS WERE FOUND ******************"
+34 SET PSJLINE=0
SET ON=""
KILL PSJOC
FOR
SET ON=$ORDER(^TMP("PSJNOTUNDC",$JOB,DFN,ON))
if ON=""
QUIT
Begin DoDot:2
+35 SET (SM,WS,NF,PSJDISP)=""
+36 IF ON["U"
DO DSPLORDU^PSJLMUT1(DFN,ON)
Begin DoDot:3
+37 SET SM=$SELECT('$PIECE(^PS(55,DFN,5,+ON,0),"^",5):0,$PIECE(^PS(55,DFN,5,+ON,0),"^",6):1,1:2)
+38 SET PSJPWD=$PIECE($GET(^DPT(DFN,.1)),U)
SET PSJPWD=$ORDER(^DIC(42,"B",PSJPWD,0))
SET WS=$$WS^PSJO(PSJPWD,DFN,"^PS(55,"_DFN_",5,",ON)
+39 FOR PSJDISP=0:0
SET PSJDISP=$ORDER(^PS(55,DFN,5,+ON,1,PSJDISP))
if 'PSJDISP
QUIT
Begin DoDot:4
+40 IF $PIECE($GET(^PSDRUG(+$PIECE($GET(^PS(55,DFN,5,+ON,1,PSJDISP,0)),"^"),0)),"^",9)=1
SET NF=1
End DoDot:4
+41 IF NF!WS!SM
SET PSJOC(ON,PSJLINE-2)=PSJOC(ON,PSJLINE-2)_" "_$SELECT(NF:"NF ",WS:"WS ",SM:$EXTRACT("HSM",SM,3),1:"")
End DoDot:3
+42 IF ON["V"
DO DSPLORDV^PSJLMUT1(DFN,ON)
End DoDot:2
+43 SET LINE=LINE+1
SET CNT1=0
SET ON=""
FOR
SET ON=$ORDER(PSJOC(ON))
if ON=""
QUIT
Begin DoDot:2
+44 SET CNT=1
SET CNT1=CNT1+1
+45 SET ON2=""
FOR
SET ON2=$ORDER(PSJOC(ON,ON2))
if ON2=""
QUIT
Begin DoDot:3
+46 SET PSJ(LINE,0)=$JUSTIFY($SELECT(CNT=1:CNT1,1:" "),3)_$SELECT(CNT=0:" ",1:"")_PSJOC(ON,ON2)
+47 SET LINE=LINE+1
SET CNT=0
End DoDot:3
End DoDot:2
End DoDot:1
+48 DO ^XMD
IF $DATA(XMZ)
SET DA=XMZ
SET DIE=3.9
SET DR="1.7///P;"
DO ^DIE
+49 ;
DONE ;
+1 KILL PSJ,PSJOC,XMDUZ,XMSUB,XMTEXT,PSJLINE,^TMP("PSJUNDC",$JOB),^TMP("PSJNOTUNDC",$JOB),PSJENTO($JOB)
+2 QUIT
