PSGAPP ;BIR/CML3-PRINT DATA FOR ACTION PROFILE ;05 Oct 98 / 10:36 AM
;;5.0;INPATIENT MEDICATIONS;**8,20,60,50,111,169,275**;16 DEC 97;Build 157
;
LOOP ;
N PSJCLNM,PSJCLNM1,PSJCLN S (PSJCLN,PSJCLNM)=""
D NOW^%DTC S PSGDT=%,DT=$$DT^XLFDT,PSGPDT=$$ENDTC2^PSGMI(PSGDT),CML=IO'=IO(0)!($E(IOST,1,2)'="C-")
U IO I '$D(^TMP($J)) W:$Y @IOF W !?28,"UNIT DOSE ACTION PROFILE",?62,PSGPDT,!?10,"NO ACTIVE ORDERS FOUND FOR ",$S(PSGSS="G":"WARD GROUP: "_PSGAPWGN,PSGSS="W":"WARD: "_PSGAPWDN,1:"PATIENT(S) SELECTED"),"." G DONE
S PSGVAMC=$$SITE^PSGMMAR2(80)
S (LN,LINE,ALN)="",$P(LN,"_",19)="",$P(LINE,"-",81)="",$P(ALN," -",18)="",ALN=ALN_" A C T I V E"_ALN
S (PN,WD,TM)="" F S WD=$O(^TMP($J,WD)) Q:WD=""!$D(PSJDLW) F S TM=$O(^TMP($J,WD,TM)) Q:TM=""!$D(PSJDLW) F S PN=$O(^TMP($J,WD,TM,PN)) Q:PN=""!$D(PSJDLW) D
. ;naked reference on line below refers to the full reference on the line above
. S PI=$G(^(PN)),AMO=0 S:PI="" PI=$G(^TMP($J,WD,"zz",PN)) D H1
;
DONE ;
W:CML&($Y) @IOF K AD,ALN,AMO,CML,DF,LINE,LN,MF,N,PG,PI,PPN,PSGPDT,RCT,RF,PID,TD,TM,WD,PSJDLW,PSJTEAM,PSGVAMC,PSJCNTR,PSJAMO Q
;
H1 ;
Q:$D(PSJDLW)
I ($P($G(WD),"^")="z") S PSJCLNM=$P(WD,"^",2) S ALN="" S $P(ALN," -",(80-$L(PSJCLNM))\4)="",ALN=ALN_" "_PSJCLNM_" "_ALN
I $E(IOST,1)="C" K DIR S DIR(0)="E" D ^DIR K DIR S:$D(DTOUT)!$D(DUOUT) PSJDLW=1 I $D(DTOUT)!$D(DUOUT) Q
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),PI=$P(PI,"^",4),PPN=$P(PN,"^",2),(DFN,PSGP)=$P(PN,"^",3) S:('DFN&($O(PSGPAT("")))) (DFN,PSGP)=$O(PSGPAT(""))
S PAGE=$P(PDOB,";",2),PDOB=$P(PDOB,";"),PG=1 W:$Y @IOF W !?26,"UNIT DOSE ACTION PROFILE #1",?62,PSGPDT
W !?+PSGVAMC,$P(PSGVAMC,U,2)
W !?23,"(Continuation of VA FORM 10-1158)",?72,"Page: 1",!,LINE
W !," This form is to be used to REVIEW/RENEW/CANCEL existing active medication",!," orders for inpatients. Review the active orders listed and beside"
W " each order",!," circle one of the following:",!?30,"R - to RENEW the order",!?30,"D - to DISCONTINUE the order",!?30,"N - to take NO ACTION (the order will remain",!?34,"active until the stop date indicated)"
W !!," A new order must be written for any new medication or to make any changes",!," in dosage or directions on an existing order.",!,LINE,!
S PSJOPC="" D ENTRY^PSJHEAD(DFN,PSJOPC,PG,$G(PSJNARC),$G(PSJTEAM,1),1)
W !,LINE,!," No. Action",?16,"Drug",?52,"ST Start Stop Status/Info",!,ALN
END ;
N ON S (ON,DRG)="" F S DRG=$O(^TMP($J,WD,TM,PN,DRG)) Q:DRG="" F S ON=$O(^TMP($J,WD,TM,PN,DRG,ON)) Q:ON="" D
.I ($P(DRG,"^")="zz") S PSJCLNM1=$G(PSJCLNM) S PSJCLN=+$G(^PS(55,PSGP,5,+ON,8)) I PSJCLN S PSJCLNM=$P($G(^SC(+PSJCLN,0)),"^") I PSJCLNM'=PSJCLNM1 D
..S ALN="" S $P(ALN," -",(80-$L(PSJCLNM))\4)="",ALN=ALN_" "_PSJCLNM_" "_ALN W !,ALN
.S ND=^TMP($J,WD,TM,PN,DRG,ON),SI=$G(^(ON,1)) D NP:$Y+11>IOSL Q:$D(PSJDLW) D ORDP
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+11>IOSL NP1 W:'$D(PSJDLW) !!!?10,"MULTIDISCIPLINARY REVIEW",!?16,"(WHEN APPROPRIATE)",?40,LN_LN,!?40,"PHARMACIST'S SIGNATURE"
D:$Y+7>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>11 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
. S AMO=1
I W !!?16,LN,?40,LN_LN,!?16,"Date AND Time",?40,"PROVIDER'S SIGNATURE",!
E I $Y+6<IOSL F Q=$Y+5:1:IOSL-1 W !
W:'$D(PSJDLW) !?2,PPN,?40,PID,?78-$L(PDOB),PDOB
; PSJ*5*169 Standardize AMO section to 10 lines.
I 'AMO D
.S AMO=1 D NP1 Q:$D(PSJDLW) 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
.W:'$D(PSJDLW) !!?16,LN,?40,LN_LN,!?16,"Date AND Time",?40,"PROVIDER'S SIGNATURE",!
.W:'$D(PSJDLW) !?2,PPN,?40,PID,?78-$L(PDOB),PDOB
Q
;
ORDP ;
N DRG2 I ($P(DRG,"^")="zz") S DRG2=DRG N DRG S DRG=$P(DRG2,"^",3)
S N=N+1 I ND="" D PRT^PSGAPIV(ON) Q
N X,PSG S PSGP=$P(PN,U,3)
D DRGDISP^PSJLMUT1(+PSGP,+ON_"U",39,65,.PSG,0)
S SM=$P(ND,"^",5),NF=$P(ND,"^",6) W !,$J(N,3) W $S($P(DRG,"^")="O":" ",1:" R")_" D N " ;PSJ*5*169 Don't allow RENEW for one-time orders.
W PSG(1),?52,$P(DRG,U),?55,$P(ND,U,2),?61,$P(ND,U,3),?67,$P(ND,U) I NF!SM!$P(ND,U,4) W ?71 W:NF "NF " W:$P(ND,U,4) "WS " W:SM $E("HSM",SM,3)
N X F X=1:0 S X=$O(PSG(X)) Q:'X W !?11,PSG(X)
I SI]"" W !?11,"Special Instructions: " D
.N Y F X=1:1:$L(SI," ") S Y=$P(SI," ",X) W:$X+$L(Y)>78 !?35 W Y," "
W ! Q
;
NP ;
Q:$G(PSJDLW)
W !!?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
I $Y+5<IOSL F Q=$Y:1:IOSL-4 W !
S PG=PG+1 W:'AMO !?2,PPN,?40,PID,?78-$L(PDOB),PDOB W:$Y @IOF W !?26,"UNIT DOSE ACTION PROFILE #1",?73-$L(PG),"Page: "_PG
W !?+PSGVAMC,$P(PSGVAMC,U,2)
W !?1,PPN,?40,PID,?60,PDOB
; PSJ*5*169 Standardize AMO section to 10 lines.
I DF D Q
. I $G(PSJAMO)=1 W !!,"ADDITIONAL MEDICATION ORDERS (CONTINUED):",! Q
. W !!,LINE
W:'AMO !!," No. Action",?16,"Drug",?52,"ST Start Stop Status/Info",!,ALN Q
;
ENRCT ;
N DFN,GMRA,GMRAL,RCT,X S DFN=PSGP,GMRA="0^0^111" D EN1^GMRADPT
S X=0 F S X=$O(GMRAL(X)) Q:'X I $P(GMRAL(X),"^",2)]"" S RCT($P(GMRAL(X),"^",2))=""
I '$D(RCT) W " ____________________" Q
S RCT="" F X=0:1 S RCT=$O(RCT(RCT)) Q:RCT="" W:X "," W:$X+$L(RCT)>77 ! W " ",$S(RCT="NKA":"No Known Allergies",1:RCT)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGAPP 5677 printed Apr 09, 2024@21:08:12 Page 2
PSGAPP ;BIR/CML3-PRINT DATA FOR ACTION PROFILE ;05 Oct 98 / 10:36 AM
+1 ;;5.0;INPATIENT MEDICATIONS;**8,20,60,50,111,169,275**;16 DEC 97;Build 157
+2 ;
LOOP ;
+1 NEW PSJCLNM,PSJCLNM1,PSJCLN
SET (PSJCLN,PSJCLNM)=""
+2 DO NOW^%DTC
SET PSGDT=%
SET DT=$$DT^XLFDT
SET PSGPDT=$$ENDTC2^PSGMI(PSGDT)
SET CML=IO'=IO(0)!($EXTRACT(IOST,1,2)'="C-")
+3 USE IO
IF '$DATA(^TMP($JOB))
if $Y
WRITE @IOF
WRITE !?28,"UNIT DOSE ACTION PROFILE",?62,PSGPDT,!?10,"NO ACTIVE ORDERS FOUND FOR ",$SELECT(PSGSS="G":"WARD GROUP: "_PSGAPWGN,PSGSS="W":"WARD: "_PSGAPWDN,1:"PATIENT(S) SELECTED"),"."
GOTO DONE
+4 SET PSGVAMC=$$SITE^PSGMMAR2(80)
+5 SET (LN,LINE,ALN)=""
SET $PIECE(LN,"_",19)=""
SET $PIECE(LINE,"-",81)=""
SET $PIECE(ALN," -",18)=""
SET ALN=ALN_" A C T I V E"_ALN
+6 SET (PN,WD,TM)=""
FOR
SET WD=$ORDER(^TMP($JOB,WD))
if WD=""!$DATA(PSJDLW)
QUIT
FOR
SET TM=$ORDER(^TMP($JOB,WD,TM))
if TM=""!$DATA(PSJDLW)
QUIT
FOR
SET PN=$ORDER(^TMP($JOB,WD,TM,PN))
if PN=""!$DATA(PSJDLW)
QUIT
Begin DoDot:1
+7 ;naked reference on line below refers to the full reference on the line above
+8 SET PI=$GET(^(PN))
SET AMO=0
if PI=""
SET PI=$GET(^TMP($JOB,WD,"zz",PN))
DO H1
End DoDot:1
+9 ;
DONE ;
+1 if CML&($Y)
WRITE @IOF
KILL AD,ALN,AMO,CML,DF,LINE,LN,MF,N,PG,PI,PPN,PSGPDT,RCT,RF,PID,TD,TM,WD,PSJDLW,PSJTEAM,PSGVAMC,PSJCNTR,PSJAMO
QUIT
+2 ;
H1 ;
+1 if $DATA(PSJDLW)
QUIT
+2 IF ($PIECE($GET(WD),"^")="z")
SET PSJCLNM=$PIECE(WD,"^",2)
SET ALN=""
SET $PIECE(ALN," -",(80-$LENGTH(PSJCLNM))\4)=""
SET ALN=ALN_" "_PSJCLNM_" "_ALN
+3 IF $EXTRACT(IOST,1)="C"
KILL DIR
SET DIR(0)="E"
DO ^DIR
KILL DIR
if $DATA(DTOUT)!$DATA(DUOUT)
SET PSJDLW=1
IF $DATA(DTOUT)!$DATA(DUOUT)
QUIT
+4 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 PI=$PIECE(PI,"^",4)
SET PPN=$PIECE(PN,"^",2)
SET (DFN,PSGP)=$PIECE(PN,"^",3)
if ('DFN&($ORDER(PSGPAT(""))))
SET (DFN,PSGP)=$ORDER(PSGPAT(""))
+5 SET PAGE=$PIECE(PDOB,";",2)
SET PDOB=$PIECE(PDOB,";")
SET PG=1
if $Y
WRITE @IOF
WRITE !?26,"UNIT DOSE ACTION PROFILE #1",?62,PSGPDT
+6 WRITE !?+PSGVAMC,$PIECE(PSGVAMC,U,2)
+7 WRITE !?23,"(Continuation of VA FORM 10-1158)",?72,"Page: 1",!,LINE
+8 WRITE !," This form is to be used to REVIEW/RENEW/CANCEL existing active medication",!," orders for inpatients. Review the active orders listed and beside"
+9 WRITE " each order",!," circle one of the following:",!?30,"R - to RENEW the order",!?30,"D - to DISCONTINUE the order",!?30,"N - to take NO ACTION (the order will remain",!?34,"active until the stop date indicated)"
+10 WRITE !!," A new order must be written for any new medication or to make any changes",!," in dosage or directions on an existing order.",!,LINE,!
+11 SET PSJOPC=""
DO ENTRY^PSJHEAD(DFN,PSJOPC,PG,$GET(PSJNARC),$GET(PSJTEAM,1),1)
+12 WRITE !,LINE,!," No. Action",?16,"Drug",?52,"ST Start Stop Status/Info",!,ALN
END ;
+1 NEW ON
SET (ON,DRG)=""
FOR
SET DRG=$ORDER(^TMP($JOB,WD,TM,PN,DRG))
if DRG=""
QUIT
FOR
SET ON=$ORDER(^TMP($JOB,WD,TM,PN,DRG,ON))
if ON=""
QUIT
Begin DoDot:1
+2 IF ($PIECE(DRG,"^")="zz")
SET PSJCLNM1=$GET(PSJCLNM)
SET PSJCLN=+$GET(^PS(55,PSGP,5,+ON,8))
IF PSJCLN
SET PSJCLNM=$PIECE($GET(^SC(+PSJCLN,0)),"^")
IF PSJCLNM'=PSJCLNM1
Begin DoDot:2
+3 SET ALN=""
SET $PIECE(ALN," -",(80-$LENGTH(PSJCLNM))\4)=""
SET ALN=ALN_" "_PSJCLNM_" "_ALN
WRITE !,ALN
End DoDot:2
+4 SET ND=^TMP($JOB,WD,TM,PN,DRG,ON)
SET SI=$GET(^(ON,1))
if $Y+11>IOSL
DO NP
if $DATA(PSJDLW)
QUIT
DO ORDP
End DoDot:1
+5 if $DATA(PSJDLW)
QUIT
+6 IF $DATA(^PS(53.1,"AC",PSGP))
WRITE !!?13,"******** THIS PATIENT HAS NON-VERIFIED ORDERS. ********"
+7 SET DF=1
if '$DATA(PSJDLW)
WRITE !!?16,LN,?40,LN_LN,!?16,"Date AND Time",?40,"PROVIDER'S SIGNATURE"
+8 if $Y+11>IOSL
DO NP1
if '$DATA(PSJDLW)
WRITE !!!?10,"MULTIDISCIPLINARY REVIEW",!?16,"(WHEN APPROPRIATE)",?40,LN_LN,!?40,"PHARMACIST'S SIGNATURE"
+9 if $Y+7>IOSL
DO NP1
if '$DATA(PSJDLW)
WRITE !!?40,LN_LN,!?40,"NURSE'S SIGNATURE"
+10 ; PSJ*5*169 Standardize AMO section to 10 lines.
+11 NEW PSJCNTR,PSJAMO
+12 IF IOSL-$Y>11
Begin DoDot:1
+13 WRITE !!?3,"ADDITIONAL MEDICATION ORDERS:"
+14 FOR PSJCNTR=1:1:10
WRITE !!,LINE
SET PSJAMO=0
IF $Y+9>IOSL
SET PSJAMO=1
DO NP1
+15 SET AMO=1
End DoDot:1
+16 IF $TEST
WRITE !!?16,LN,?40,LN_LN,!?16,"Date AND Time",?40,"PROVIDER'S SIGNATURE",!
+17 IF '$TEST
IF $Y+6<IOSL
FOR Q=$Y+5:1:IOSL-1
WRITE !
+18 if '$DATA(PSJDLW)
WRITE !?2,PPN,?40,PID,?78-$LENGTH(PDOB),PDOB
+19 ; PSJ*5*169 Standardize AMO section to 10 lines.
+20 IF 'AMO
Begin DoDot:1
+21 SET AMO=1
DO NP1
if $DATA(PSJDLW)
QUIT
Begin DoDot:2
+22 WRITE !!?3,"ADDITIONAL MEDICATION ORDERS:"
+23 FOR PSJCNTR=1:1:10
WRITE !!,LINE
SET PSJAMO=0
IF $Y+9>IOSL
SET PSJAMO=1
DO NP1
End DoDot:2
+24 if '$DATA(PSJDLW)
WRITE !!?16,LN,?40,LN_LN,!?16,"Date AND Time",?40,"PROVIDER'S SIGNATURE",!
+25 if '$DATA(PSJDLW)
WRITE !?2,PPN,?40,PID,?78-$LENGTH(PDOB),PDOB
End DoDot:1
+26 QUIT
+27 ;
ORDP ;
+1 NEW DRG2
IF ($PIECE(DRG,"^")="zz")
SET DRG2=DRG
NEW DRG
SET DRG=$PIECE(DRG2,"^",3)
+2 SET N=N+1
IF ND=""
DO PRT^PSGAPIV(ON)
QUIT
+3 NEW X,PSG
SET PSGP=$PIECE(PN,U,3)
+4 DO DRGDISP^PSJLMUT1(+PSGP,+ON_"U",39,65,.PSG,0)
+5 ;PSJ*5*169 Don't allow RENEW for one-time orders.
SET SM=$PIECE(ND,"^",5)
SET NF=$PIECE(ND,"^",6)
WRITE !,$JUSTIFY(N,3)
WRITE $SELECT($PIECE(DRG,"^")="O":" ",1:" R")_" D N "
+6 WRITE PSG(1),?52,$PIECE(DRG,U),?55,$PIECE(ND,U,2),?61,$PIECE(ND,U,3),?67,$PIECE(ND,U)
IF NF!SM!$PIECE(ND,U,4)
WRITE ?71
if NF
WRITE "NF "
if $PIECE(ND,U,4)
WRITE "WS "
if SM
WRITE $EXTRACT("HSM",SM,3)
+7 NEW X
FOR X=1:0
SET X=$ORDER(PSG(X))
if 'X
QUIT
WRITE !?11,PSG(X)
+8 IF SI]""
WRITE !?11,"Special Instructions: "
Begin DoDot:1
+9 NEW Y
FOR X=1:1:$LENGTH(SI," ")
SET Y=$PIECE(SI," ",X)
if $X+$LENGTH(Y)>78
WRITE !?35
WRITE Y," "
End DoDot:1
+10 WRITE !
QUIT
+11 ;
NP ;
+1 if $GET(PSJDLW)
QUIT
+2 WRITE !!?16,LN,?40,LN_LN,!?16,"Date and Time",?40,"PROVIDER'S SIGNATURE"
+3 ;
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 IF $Y+5<IOSL
FOR Q=$Y:1:IOSL-4
WRITE !
+4 SET PG=PG+1
if 'AMO
WRITE !?2,PPN,?40,PID,?78-$LENGTH(PDOB),PDOB
if $Y
WRITE @IOF
WRITE !?26,"UNIT DOSE ACTION PROFILE #1",?73-$LENGTH(PG),"Page: "_PG
+5 WRITE !?+PSGVAMC,$PIECE(PSGVAMC,U,2)
+6 WRITE !?1,PPN,?40,PID,?60,PDOB
+7 ; PSJ*5*169 Standardize AMO section to 10 lines.
+8 IF DF
Begin DoDot:1
+9 IF $GET(PSJAMO)=1
WRITE !!,"ADDITIONAL MEDICATION ORDERS (CONTINUED):",!
QUIT
+10 WRITE !!,LINE
End DoDot:1
QUIT
+11 if 'AMO
WRITE !!," No. Action",?16,"Drug",?52,"ST Start Stop Status/Info",!,ALN
QUIT
+12 ;
ENRCT ;
+1 NEW DFN,GMRA,GMRAL,RCT,X
SET DFN=PSGP
SET GMRA="0^0^111"
DO EN1^GMRADPT
+2 SET X=0
FOR
SET X=$ORDER(GMRAL(X))
if 'X
QUIT
IF $PIECE(GMRAL(X),"^",2)]""
SET RCT($PIECE(GMRAL(X),"^",2))=""
+3 IF '$DATA(RCT)
WRITE " ____________________"
QUIT
+4 SET RCT=""
FOR X=0:1
SET RCT=$ORDER(RCT(RCT))
if RCT=""
QUIT
if X
WRITE ","
if $X+$LENGTH(RCT)>77
WRITE !
WRITE " ",$SELECT(RCT="NKA":"No Known Allergies",1:RCT)
+5 QUIT
