- PSGAPP ;BIR/CML3-PRINT DATA FOR ACTION PROFILE ;29-May-2012 14:26;PLS
- ;;5.0; INPATIENT MEDICATIONS ;**8,20,60,50,111,169,1015**;16 DEC 97;Build 62
- ; Modified - IHS/CIA/PLS - 12/12/03 - Line H1+6
- LOOP ;
- 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 $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 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 !?23,"(Continuation)",?72,"Page: 1",!,LINE ; IHS/CIA/PLS - 12/12/03 - Removed VA Form
- 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 ;
- 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="" S ND=^(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 ;
- 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: " 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
- PSGAPP ;BIR/CML3-PRINT DATA FOR ACTION PROFILE ;29-May-2012 14:26;PLS
- +1 ;;5.0; INPATIENT MEDICATIONS ;**8,20,60,50,111,169,1015**;16 DEC 97;Build 62
- +2 ; Modified - IHS/CIA/PLS - 12/12/03 - Line H1+6
- LOOP ;
- +1 DO NOW^%DTC
- SET PSGDT=%
- SET DT=$$DT^XLFDT
- SET PSGPDT=$$ENDTC2^PSGMI(PSGDT)
- SET CML=IO'=IO(0)!($EXTRACT(IOST,1,2)'="C-")
- +2 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
- +3 SET PSGVAMC=$$SITE^PSGMMAR2(80)
- +4 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
- +5 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
- +6 ;naked reference on line below refers to the full reference on the line above
- +7 SET PI=$GET(^(PN))
- SET AMO=0
- IF PI=""
- SET PI=$GET(^TMP($JOB,WD,"zz",PN))
- DO H1
- End DoDot:1
- +8 ;
- 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 $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
- +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 PI=$PIECE(PI,"^",4)
- SET PPN=$PIECE(PN,"^",2)
- SET (DFN,PSGP)=$PIECE(PN,"^",3)
- +4 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
- +5 WRITE !?+PSGVAMC,$PIECE(PSGVAMC,U,2)
- +6 ;W !?23,"(Continuation of VA FORM 10-1158)",?72,"Page: 1",!,LINE
- +7 ; IHS/CIA/PLS - 12/12/03 - Removed VA Form
- WRITE !?23,"(Continuation)",?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 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
- SET ND=^(ON)
- SET SI=$GET(^(ON,1))
- IF $Y+11>IOSL
- DO NP
- IF $DATA(PSJDLW)
- QUIT
- DO ORDP
- +2 IF $DATA(PSJDLW)
- QUIT
- +3 IF $DATA(^PS(53.1,"AC",PSGP))
- WRITE !!?13,"******** THIS PATIENT HAS NON-VERIFIED ORDERS. ********"
- +4 SET DF=1
- IF '$DATA(PSJDLW)
- WRITE !!?16,LN,?40,LN_LN,!?16,"Date AND Time",?40,"PROVIDER'S SIGNATURE"
- +5 IF $Y+11>IOSL
- DO NP1
- IF '$DATA(PSJDLW)
- WRITE !!!?10,"MULTIDISCIPLINARY REVIEW",!?16,"(WHEN APPROPRIATE)",?40,LN_LN,!?40,"PHARMACIST'S SIGNATURE"
- +6 IF $Y+7>IOSL
- DO NP1
- IF '$DATA(PSJDLW)
- WRITE !!?40,LN_LN,!?40,"NURSE'S SIGNATURE"
- +7 ; PSJ*5*169 Standardize AMO section to 10 lines.
- +8 NEW PSJCNTR,PSJAMO
- +9 IF IOSL-$Y>11
- Begin DoDot:1
- +10 WRITE !!?3,"ADDITIONAL MEDICATION ORDERS:"
- +11 FOR PSJCNTR=1:1:10
- WRITE !!,LINE
- SET PSJAMO=0
- IF $Y+9>IOSL
- SET PSJAMO=1
- DO NP1
- +12 SET AMO=1
- End DoDot:1
- +13 IF $TEST
- WRITE !!?16,LN,?40,LN_LN,!?16,"Date AND Time",?40,"PROVIDER'S SIGNATURE",!
- +14 IF '$TEST
- IF $Y+6<IOSL
- FOR Q=$Y+5:1:IOSL-1
- WRITE !
- +15 IF '$DATA(PSJDLW)
- WRITE !?2,PPN,?40,PID,?78-$LENGTH(PDOB),PDOB
- +16 ; PSJ*5*169 Standardize AMO section to 10 lines.
- +17 IF 'AMO
- Begin DoDot:1
- +18 SET AMO=1
- DO NP1
- IF $DATA(PSJDLW)
- QUIT
- Begin DoDot:2
- +19 WRITE !!?3,"ADDITIONAL MEDICATION ORDERS:"
- +20 FOR PSJCNTR=1:1:10
- WRITE !!,LINE
- SET PSJAMO=0
- IF $Y+9>IOSL
- SET PSJAMO=1
- DO NP1
- End DoDot:2
- +21 IF '$DATA(PSJDLW)
- WRITE !!?16,LN,?40,LN_LN,!?16,"Date AND Time",?40,"PROVIDER'S SIGNATURE",!
- +22 IF '$DATA(PSJDLW)
- WRITE !?2,PPN,?40,PID,?78-$LENGTH(PDOB),PDOB
- End DoDot:1
- +23 QUIT
- +24 ;
- ORDP ;
- +1 SET N=N+1
- IF ND=""
- DO PRT^PSGAPIV(ON)
- QUIT
- +2 NEW X,PSG
- SET PSGP=$PIECE(PN,U,3)
- +3 DO DRGDISP^PSJLMUT1(+PSGP,+ON_"U",39,65,.PSG,0)
- +4 ;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 "
- +5 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)
- +6 NEW X
- FOR X=1:0
- SET X=$ORDER(PSG(X))
- IF 'X
- QUIT
- WRITE !?11,PSG(X)
- +7 IF SI]""
- WRITE !?11,"Special Instructions: "
- FOR X=1:1:$LENGTH(SI," ")
- SET Y=$PIECE(SI," ",X)
- IF $X+$LENGTH(Y)>78
- WRITE !?35
- WRITE Y," "
- +8 WRITE !
- QUIT
- +9 ;
- 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
