PSGCAPP ;BIR/CML3-PRINT DATA FOR ACTION PROFILE ;05 Oct 98 / 10:21 AM
;;5.0; INPATIENT MEDICATIONS ;**8,20,60,111,149,169**;16 DEC 97
LOOP ;
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)) 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 $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
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 !
;* 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=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
W !!," No. Action",?16,"Drug",?46,"ST Start Stop Status/Info",!,ALN
Q
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**;16 DEC 97
LOOP ;
+1 DO NOW^%DTC
SET PSGDT=%
SET PSGPDT=$$ENDTC2^PSGMI(PSGDT)
SET CML=IO'=IO(0)!($EXTRACT(IOST,1,2)'="C-")
+2 USE IO
IF '$DATA(^TMP($JOB))
Begin DoDot:1
+3 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
+4 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
+5 SET PSGVAMC=$$SITE^PSGMMAR2(80)
+6 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
+7 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))
DO H1
End DoDot:1
+8 ;
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 $GET(WD)="zz"
SET WD1=WD
NEW WD
SET WD="*NF*"
+4 DO ^PSGCAPP0
+5 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 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+10>IOSL
DO NP1
IF '$DATA(PSJDLW)
WRITE !!!?10,"MULTIDISCIPLINARY REVIEW",!?16,"(WHEN APPROPRIATE)",?40,LN_LN,!?40,"PHARMACIST'S SIGNATURE"
+6 IF $Y+6>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>10
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
End DoDot:1
+12 IF $TEST
IF '$DATA(PSJDLW)
WRITE !!?16,LN,?40,LN_LN,!?16,"Date AND Time",?40,"PROVIDER'S SIGNATURE",!
+13 IF '$TEST
FOR Q=$Y+5:1:IOSL-1
WRITE !
+14 IF '$DATA(PSJDLW)
WRITE !?2,PPN,?40,PID,?78-$LENGTH(PDOB),PDOB
QUIT
+15 ;
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 ;* 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
+5 SET PG=PG+1
WRITE !?2,PPN,?40,PID,?78-$LENGTH(PDOB),PDOB
IF $Y
WRITE @IOF
+6 WRITE !?26,"UNIT DOSE ACTION PROFILE #2",?73-$LENGTH(PG),"Page: "_PG
+7 WRITE !?+PSGVAMC,$PIECE(PSGVAMC,U,2)
+8 WRITE !?1,PPN,?40,PID,?60,PDOB
+9 IF DF
Begin DoDot:1
+10 IF $GET(PSJAMO)=1
WRITE !!,"ADDITIONAL MEDICATION ORDERS (CONTINUED):",!
QUIT
+11 WRITE !!,LINE
End DoDot:1
QUIT
+12 WRITE !!," No. Action",?16,"Drug",?46,"ST Start Stop Status/Info",!,ALN
+13 QUIT
