- 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 Feb 18, 2025@23:27:19 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
