PSGCAPP ;BIR/CML3-PRINT DATA FOR ACTION PROFILE ;05 Oct 98 / 10:21 AM
;;5.0;INPATIENT MEDICATIONS;**8,20,60,111,149,169,275,301**;16 DEC 97;Build 3
LOOP ;
N PSJCLIN1
D NOW^%DTC S PSGDT=%,PSGPDT=$$ENDTC2^PSGMI(PSGDT),CML=IO'=IO(0)!($E(IOST,1,2)'="C-")
U IO I '$D(^TMP($J)) D G DONE
.W:$Y @IOF W !?26,"UNIT DOSE ACTION PROFILE #2",?62,PSGPDT,!?10,"NO ",$S(PSGAPO="E":"EXPIRING",1:"ACTIVE")," ORDERS FOUND FOR ",$S(PSGSS="G":"WARD GROUP: "_PSGAPWGN,PSGSS="W":"WARD: "_PSGAPWDN,1:"PATIENT(S) SELECTED"),"."
S (LN,LINE,ALN,S1,WD,PN)="",$P(LN,"_",19)="",$P(LINE,"-",81)="",$P(ALN," -",18)="",ALN=ALN_" A C T I V E"_ALN
S PSGVAMC=$$SITE^PSGMMAR2(80)
F S (PS1,S1,PSJTEAM)=$O(^TMP($J,S1)) Q:S1=""!$D(PSJDLW) S:S1="zz" (PS1,PSJTEAM)="NOT FOUND" F S WD=$O(^TMP($J,S1,WD)) Q:WD=""!$D(PSJDLW) D
. F S PN=$O(^TMP($J,S1,WD,PN)) Q:PN=""!$D(PSJDLW) S PI=$G(^(PN)) S:PI="" PI=$G(^TMP($J,S1,"zz",PN)) S:((PI="")&$P($G(PN),"^",2)) PI=$$SETPI^PSGCAP0($P(PN,"^",2)) D H1
;
DONE ;PSJ*5*149 Add WD1 to killed variables.
W:CML&($Y) @IOF K AD,ALN,CML,DF,LINE,LN,MF,N,PG,PI,PPN,PS1,PSGPDT,RCT,RF,PID,TD,WD,PSJDLW,PSGVAMC,WD1,PSJCNTR,PSJAMO Q
;
H1 ; first header for patient
; PSJ*5*149 Use WD1 to preserve value of WD
N WD1
I $P(WD,"^")="zz",($P(WD,"^",2)]"") I ($P(WD,"^",2)'=$P($G(PSJCLIN1),"^",2)) S PSJCLIN1=WD D
.N MIDLEN,SIDLEN S MIDLEN=$L($P(PSJCLIN1,"^",2)) S SIDLEN=((81-MIDLEN)\2)
.S (LN,LINE,ALN)="",$P(LN,"_",(SIDLEN\2))="",$P(LINE,"-",81)="",$P(ALN," -",(SIDLEN\2))="",ALN=ALN_$P(PSJCLIN1,"^",2)_ALN
I $G(WD)="zz" S WD1=WD N WD S WD="*NF*"
D ^PSGCAPP0
S WD=$G(WD1,WD)
END ;
S (ON,DRG)="" F S DRG=$O(^TMP($J,S1,WD,PN,DRG)) Q:DRG="" F S ON=$O(^TMP($J,S1,WD,PN,DRG,ON)) Q:ON="" S ND=^(ON),SI=$G(^(ON,1)) D NP:$Y+12>IOSL Q:$D(PSJDLW) D ORDP
; Check for orders in other locations for the same patient; ensure all of one patient's orders display in the same section of the report
N WD2,PN2,DRG2,ON2 S WD2="" F S WD2=$O(^TMP($J,S1,WD2)) Q:WD2="" I WD2'=WD S PN2="" F S PN2=$O(^TMP($J,S1,WD2,PN2)) Q:PN2="" I PN2=PN S (WD2(WD2),DRG2)="" F S DRG2=$O(^TMP($J,S1,WD2,PN2,DRG2)) Q:DRG2="" D
.S ON2="" F S ON2=$O(^TMP($J,S1,WD2,PN2,DRG2,ON2)) Q:ON2="" N WD,DRG,ON S WD=WD2,DRG=DRG2,ON=ON2 S ND=^(ON),SI=$G(^(ON,1)) D NP Q:$D(PSJDLW) D ORDP
; Remove the previously printed orders from the 'other' locations so they are not printed again later
N TMPWD S TMPWD="" F S TMPWD=$O(WD2(TMPWD)) Q:TMPWD="" K ^TMP($J,S1,TMPWD,PN)
Q:$D(PSJDLW)
I $D(^PS(53.1,"AC",PSGP)) W !!?13,"******** THIS PATIENT HAS NON-VERIFIED ORDERS. ********"
S DF=1 W:'$D(PSJDLW) !!?16,LN,?40,LN_LN,!?16,"Date AND Time",?40,"PROVIDER'S SIGNATURE"
D:$Y+10>IOSL NP1 W:'$D(PSJDLW) !!!?10,"MULTIDISCIPLINARY REVIEW",!?16,"(WHEN APPROPRIATE)",?40,LN_LN,!?40,"PHARMACIST'S SIGNATURE"
D:$Y+6>IOSL NP1 W:'$D(PSJDLW) !!?40,LN_LN,!?40,"NURSE'S SIGNATURE"
; PSJ*5*169 Standardize AMO section to 10 lines.
N PSJCNTR,PSJAMO
I IOSL-$Y>10 D
. W !!?3,"ADDITIONAL MEDICATION ORDERS:"
. F PSJCNTR=1:1:10 W !!,LINE S PSJAMO=0 I $Y+9>IOSL S PSJAMO=1 D NP1
I W:'$D(PSJDLW) !!?16,LN,?40,LN_LN,!?16,"Date AND Time",?40,"PROVIDER'S SIGNATURE",!
E F Q=$Y+5:1:IOSL-1 W !
W:'$D(PSJDLW) !?2,PPN,?40,PID,?78-$L(PDOB),PDOB Q
;
ORDP ;
S N=N+1 I ON["V" D PRT^PSGCAPIV(ON) Q
N X,PSG S PSGP=$P(PN,U,2)
D DRGDISP^PSJLMUT1(+PSGP,+ON_"U",39,69,.PSG,0)
S SM=$P(ND,"^",5),NF=$P(ND,"^",6),DCU=$P(ND,"^",7),DCU=$S($E(DCU)=".":"0"_DCU,'DCU:"0.00",1:DCU) W !,$J(N,3)
W ?5,PSG(1),?46,$P(DRG,"^"),?49,$P(ND,"^",2),?55,$P(ND,"^",3),?61,$P(ND,"^") I NF!SM!$P(ND,"^",4) W ?65 W:NF "NF " W:$P(ND,"^",4) "WS " W:SM $E("HSM",SM,3)
N X F X=1:0 S X=$O(PSG(X)) Q:'X W !?5,PSG(X)
I SI]"" W !?8,"Special Instructions: " F X=1:1:$L(SI," ") S Y=$P(SI," ",X) W:$X+$L(Y)>78 !?31 W Y," "
ORDP1 ;*** Also being called from ^PSGCAPIV. PSJ*5*169 Don't allow RENEW on one-time orders.
W !!?5,"__TAKE NO ACTION __DISCONTINUE "_$S($P(DRG,"^")="O"!($G(QST)="O"):" ",1:"__RENEW")_" COST/DOSE: ",DCU,!?2,"------------------------------------------------------------------------",! Q
;
NP ;
W:'$D(PSJDLW) !!?16,LN,?40,LN_LN,!?16,"Date AND Time",?40,"PROVIDER'S SIGNATURE"
;
NP1 ;
Q:$D(PSJDLW)
I $E(IOST,1)="C" K DIR S DIR(0)="E" D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S PSJDLW=1 Q
F Q=$Y:1:IOSL-4 W !
I '$G(PG),$P($G(PI),"^",3) S (N,DF)=0,PSEX=$P(PI,"^"),PDOB=$P(PI,"^",2),PID=$P(PI,"^",3),RB=$P(PI,"^",5),AD=$P(PI,"^",6),TD=$P(PI,"^",7),WT=$P(PI,"^",8),WTD=$P(PI,"^",9),HT=$P(PI,"^",10),HTD=$P(PI,"^",11),PPN=$P(PI,"^",12),PSGP=$P(PN,"^",2) D
.S PAGE=$P(PDOB,";",2),PDOB=$P(PDOB,";"),PG=1
;* S PG=PG+1 W !?2,PPN,?40,PID,?78-$L(PDOB),PDOB W:$Y @IOF W !?28,"UNIT DOSE ACTION PROFILE #2",?73-$L(PG),"Page: "_PG,!?1,PPN,?40,PID,?60,PDOB I DF W !!,LINE Q
S PG=$G(PG)+1 W !?2,PPN,?40,PID,?78-$L(PDOB),PDOB W:$Y @IOF
W !?26,"UNIT DOSE ACTION PROFILE #2",?73-$L(PG),"Page: "_PG
W !?+PSGVAMC,$P(PSGVAMC,U,2)
W !?1,PPN,?40,PID,?60,PDOB
I DF D Q
. I $G(PSJAMO)=1 W !!,"ADDITIONAL MEDICATION ORDERS (CONTINUED):",! Q
. W !!,LINE
; Make sure orders always have correct profile heading - ACTIVE for Inpatient orders, clinic name for Clinic Orders
I ($$CLINIC^PSJO1($P(PN,"^",2),+ON_"U")]"") N ALN S ALN="" S $P(ALN," -",18)="",ALN=ALN_$$CLINIC^PSJO1($P(PN,"^",2),+ON_"U")_ALN
I ($$CLINIC^PSJO1($P(PN,"^",2),+ON_"U")=""),$G(PSJPWD) N ALN S ALN="" S $P(ALN," -",18)="",ALN=ALN_" A C T I V E"_ALN
W !!," No. Action",?16,"Drug",?46,"ST Start Stop Status/Info",!,ALN
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGCAPP 5508 printed Sep 23, 2025@19:37:02 Page 2
PSGCAPP ;BIR/CML3-PRINT DATA FOR ACTION PROFILE ;05 Oct 98 / 10:21 AM
+1 ;;5.0;INPATIENT MEDICATIONS;**8,20,60,111,149,169,275,301**;16 DEC 97;Build 3
LOOP ;
+1 NEW PSJCLIN1
+2 DO NOW^%DTC
SET PSGDT=%
SET PSGPDT=$$ENDTC2^PSGMI(PSGDT)
SET CML=IO'=IO(0)!($EXTRACT(IOST,1,2)'="C-")
+3 USE IO
IF '$DATA(^TMP($JOB))
Begin DoDot:1
+4 if $Y
WRITE @IOF
WRITE !?26,"UNIT DOSE ACTION PROFILE #2",?62,PSGPDT,!?10,"NO ",$SELECT(PSGAPO="E":"EXPIRING",1:"ACTIVE")," ORDERS FOUND FOR ",$SELECT(PSGSS="G":"WARD GROUP: "_PSGAPWGN,PSGSS="W":"WARD: "_PSGAPWDN,1:"PATIENT(S) SELECTED"),"."
End DoDot:1
GOTO DONE
+5 SET (LN,LINE,ALN,S1,WD,PN)=""
SET $PIECE(LN,"_",19)=""
SET $PIECE(LINE,"-",81)=""
SET $PIECE(ALN," -",18)=""
SET ALN=ALN_" A C T I V E"_ALN
+6 SET PSGVAMC=$$SITE^PSGMMAR2(80)
+7 FOR
SET (PS1,S1,PSJTEAM)=$ORDER(^TMP($JOB,S1))
if S1=""!$DATA(PSJDLW)
QUIT
if S1="zz"
SET (PS1,PSJTEAM)="NOT FOUND"
FOR
SET WD=$ORDER(^TMP($JOB,S1,WD))
if WD=""!$DATA(PSJDLW)
QUIT
Begin DoDot:1
+8 FOR
SET PN=$ORDER(^TMP($JOB,S1,WD,PN))
if PN=""!$DATA(PSJDLW)
QUIT
SET PI=$GET(^(PN))
if PI=""
SET PI=$GET(^TMP($JOB,S1,"zz",PN))
if ((PI="")&$PIECE($GET(PN),"^",2))
SET PI=$$SETPI^PSGCAP0($PIECE(PN,"^",2))
DO H1
End DoDot:1
+9 ;
DONE ;PSJ*5*149 Add WD1 to killed variables.
+1 if CML&($Y)
WRITE @IOF
KILL AD,ALN,CML,DF,LINE,LN,MF,N,PG,PI,PPN,PS1,PSGPDT,RCT,RF,PID,TD,WD,PSJDLW,PSGVAMC,WD1,PSJCNTR,PSJAMO
QUIT
+2 ;
H1 ; first header for patient
+1 ; PSJ*5*149 Use WD1 to preserve value of WD
+2 NEW WD1
+3 IF $PIECE(WD,"^")="zz"
IF ($PIECE(WD,"^",2)]"")
IF ($PIECE(WD,"^",2)'=$PIECE($GET(PSJCLIN1),"^",2))
SET PSJCLIN1=WD
Begin DoDot:1
+4 NEW MIDLEN,SIDLEN
SET MIDLEN=$LENGTH($PIECE(PSJCLIN1,"^",2))
SET SIDLEN=((81-MIDLEN)\2)
+5 SET (LN,LINE,ALN)=""
SET $PIECE(LN,"_",(SIDLEN\2))=""
SET $PIECE(LINE,"-",81)=""
SET $PIECE(ALN," -",(SIDLEN\2))=""
SET ALN=ALN_$PIECE(PSJCLIN1,"^",2)_ALN
End DoDot:1
+6 IF $GET(WD)="zz"
SET WD1=WD
NEW WD
SET WD="*NF*"
+7 DO ^PSGCAPP0
+8 SET WD=$GET(WD1,WD)
END ;
+1 SET (ON,DRG)=""
FOR
SET DRG=$ORDER(^TMP($JOB,S1,WD,PN,DRG))
if DRG=""
QUIT
FOR
SET ON=$ORDER(^TMP($JOB,S1,WD,PN,DRG,ON))
if ON=""
QUIT
SET ND=^(ON)
SET SI=$GET(^(ON,1))
if $Y+12>IOSL
DO NP
if $DATA(PSJDLW)
QUIT
DO ORDP
+2 ; Check for orders in other locations for the same patient; ensure all of one patient's orders display in the same section of the report
+3 NEW WD2,PN2,DRG2,ON2
SET WD2=""
FOR
SET WD2=$ORDER(^TMP($JOB,S1,WD2))
if WD2=""
QUIT
IF WD2'=WD
SET PN2=""
FOR
SET PN2=$ORDER(^TMP($JOB,S1,WD2,PN2))
if PN2=""
QUIT
IF PN2=PN
SET (WD2(WD2),DRG2)=""
FOR
SET DRG2=$ORDER(^TMP($JOB,S1,WD2,PN2,DRG2))
if DRG2=""
QUIT
Begin DoDot:1
+4 SET ON2=""
FOR
SET ON2=$ORDER(^TMP($JOB,S1,WD2,PN2,DRG2,ON2))
if ON2=""
QUIT
NEW WD,DRG,ON
SET WD=WD2
SET DRG=DRG2
SET ON=ON2
SET ND=^(ON)
SET SI=$GET(^(ON,1))
DO NP
if $DATA(PSJDLW)
QUIT
DO ORDP
End DoDot:1
+5 ; Remove the previously printed orders from the 'other' locations so they are not printed again later
+6 NEW TMPWD
SET TMPWD=""
FOR
SET TMPWD=$ORDER(WD2(TMPWD))
if TMPWD=""
QUIT
KILL ^TMP($JOB,S1,TMPWD,PN)
+7 if $DATA(PSJDLW)
QUIT
+8 IF $DATA(^PS(53.1,"AC",PSGP))
WRITE !!?13,"******** THIS PATIENT HAS NON-VERIFIED ORDERS. ********"
+9 SET DF=1
if '$DATA(PSJDLW)
WRITE !!?16,LN,?40,LN_LN,!?16,"Date AND Time",?40,"PROVIDER'S SIGNATURE"
+10 if $Y+10>IOSL
DO NP1
if '$DATA(PSJDLW)
WRITE !!!?10,"MULTIDISCIPLINARY REVIEW",!?16,"(WHEN APPROPRIATE)",?40,LN_LN,!?40,"PHARMACIST'S SIGNATURE"
+11 if $Y+6>IOSL
DO NP1
if '$DATA(PSJDLW)
WRITE !!?40,LN_LN,!?40,"NURSE'S SIGNATURE"
+12 ; PSJ*5*169 Standardize AMO section to 10 lines.
+13 NEW PSJCNTR,PSJAMO
+14 IF IOSL-$Y>10
Begin DoDot:1
+15 WRITE !!?3,"ADDITIONAL MEDICATION ORDERS:"
+16 FOR PSJCNTR=1:1:10
WRITE !!,LINE
SET PSJAMO=0
IF $Y+9>IOSL
SET PSJAMO=1
DO NP1
End DoDot:1
+17 IF $TEST
if '$DATA(PSJDLW)
WRITE !!?16,LN,?40,LN_LN,!?16,"Date AND Time",?40,"PROVIDER'S SIGNATURE",!
+18 IF '$TEST
FOR Q=$Y+5:1:IOSL-1
WRITE !
+19 if '$DATA(PSJDLW)
WRITE !?2,PPN,?40,PID,?78-$LENGTH(PDOB),PDOB
QUIT
+20 ;
ORDP ;
+1 SET N=N+1
IF ON["V"
DO PRT^PSGCAPIV(ON)
QUIT
+2 NEW X,PSG
SET PSGP=$PIECE(PN,U,2)
+3 DO DRGDISP^PSJLMUT1(+PSGP,+ON_"U",39,69,.PSG,0)
+4 SET SM=$PIECE(ND,"^",5)
SET NF=$PIECE(ND,"^",6)
SET DCU=$PIECE(ND,"^",7)
SET DCU=$SELECT($EXTRACT(DCU)=".":"0"_DCU,'DCU:"0.00",1:DCU)
WRITE !,$JUSTIFY(N,3)
+5 WRITE ?5,PSG(1),?46,$PIECE(DRG,"^"),?49,$PIECE(ND,"^",2),?55,$PIECE(ND,"^",3),?61,$PIECE(ND,"^")
IF NF!SM!$PIECE(ND,"^",4)
WRITE ?65
if NF
WRITE "NF "
if $PIECE(ND,"^",4)
WRITE "WS "
if SM
WRITE $EXTRACT("HSM",SM,3)
+6 NEW X
FOR X=1:0
SET X=$ORDER(PSG(X))
if 'X
QUIT
WRITE !?5,PSG(X)
+7 IF SI]""
WRITE !?8,"Special Instructions: "
FOR X=1:1:$LENGTH(SI," ")
SET Y=$PIECE(SI," ",X)
if $X+$LENGTH(Y)>78
WRITE !?31
WRITE Y," "
ORDP1 ;*** Also being called from ^PSGCAPIV. PSJ*5*169 Don't allow RENEW on one-time orders.
+1 WRITE !!?5,"__TAKE NO ACTION __DISCONTINUE "_$SELECT($PIECE(DRG,"^")="O"!($GET(QST)="O"):" ",1:"__RENEW")_" COST/DOSE: ",DCU,!?2,"------------------------------------------------------------------------",!
QUIT
+2 ;
NP ;
+1 if '$DATA(PSJDLW)
WRITE !!?16,LN,?40,LN_LN,!?16,"Date AND Time",?40,"PROVIDER'S SIGNATURE"
+2 ;
NP1 ;
+1 if $DATA(PSJDLW)
QUIT
+2 IF $EXTRACT(IOST,1)="C"
KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
IF $DATA(DTOUT)!$DATA(DUOUT)
SET PSJDLW=1
QUIT
+3 FOR Q=$Y:1:IOSL-4
WRITE !
+4 IF '$GET(PG)
IF $PIECE($GET(PI),"^",3)
SET (N,DF)=0
SET PSEX=$PIECE(PI,"^")
SET PDOB=$PIECE(PI,"^",2)
SET PID=$PIECE(PI,"^",3)
SET RB=$PIECE(PI,"^",5)
SET AD=$PIECE(PI,"^",6)
SET TD=$PIECE(PI,"^",7)
SET WT=$PIECE(PI,"^",8)
SET WTD=$PIECE(PI,"^",9)
SET HT=$PIECE(PI,"^",10)
SET HTD=$PIECE(PI,"^",11)
SET PPN=$PIECE(PI,"^",12)
SET PSGP=$PIECE(PN,"^",2)
Begin DoDot:1
+5 SET PAGE=$PIECE(PDOB,";",2)
SET PDOB=$PIECE(PDOB,";")
SET PG=1
End DoDot:1
+6 ;* S PG=PG+1 W !?2,PPN,?40,PID,?78-$L(PDOB),PDOB W:$Y @IOF W !?28,"UNIT DOSE ACTION PROFILE #2",?73-$L(PG),"Page: "_PG,!?1,PPN,?40,PID,?60,PDOB I DF W !!,LINE Q
+7 SET PG=$GET(PG)+1
WRITE !?2,PPN,?40,PID,?78-$LENGTH(PDOB),PDOB
if $Y
WRITE @IOF
+8 WRITE !?26,"UNIT DOSE ACTION PROFILE #2",?73-$LENGTH(PG),"Page: "_PG
+9 WRITE !?+PSGVAMC,$PIECE(PSGVAMC,U,2)
+10 WRITE !?1,PPN,?40,PID,?60,PDOB
+11 IF DF
Begin DoDot:1
+12 IF $GET(PSJAMO)=1
WRITE !!,"ADDITIONAL MEDICATION ORDERS (CONTINUED):",!
QUIT
+13 WRITE !!,LINE
End DoDot:1
QUIT
+14 ; Make sure orders always have correct profile heading - ACTIVE for Inpatient orders, clinic name for Clinic Orders
+15 IF ($$CLINIC^PSJO1($PIECE(PN,"^",2),+ON_"U")]"")
NEW ALN
SET ALN=""
SET $PIECE(ALN," -",18)=""
SET ALN=ALN_$$CLINIC^PSJO1($PIECE(PN,"^",2),+ON_"U")_ALN
+16 IF ($$CLINIC^PSJO1($PIECE(PN,"^",2),+ON_"U")="")
IF $GET(PSJPWD)
NEW ALN
SET ALN=""
SET $PIECE(ALN," -",18)=""
SET ALN=ALN_" A C T I V E"_ALN
+17 WRITE !!," No. Action",?16,"Drug",?46,"ST Start Stop Status/Info",!,ALN
+18 QUIT
