- PSJINVW ;BIR/CML3-INSTRUCTION HISTORY ;17 SEP 97 / 1:41 PM
- ;;5.0;INPATIENT MEDICATIONS;**267,275**;16 DEC 97;Build 157
- ;
- ; Reference to ^PS(50.7 is supported by DBIA# 2180.
- ; Reference to ^PS(51.2 is supported by DBIA# 2178.
- ; Reference to ^PS(55 is supported by DBIA# 2191.
- ;
- EN0(PSJINHIS,PSJCHTO) ;
- N PNM,PSJFULL S PSJFULL=20
- D EN2 Q
- Q
- EN2 ;
- I PSGORD=+PSGORD N PSGO,PSGO1 S PSGO=PSGORD,PSGO1=0 F S PSGO1=$O(^PS(53.1,"ACX",PSGO,PSGO1)) Q:'PSGO1 Q:$G(PSGOEA)["^" S PSGORD=PSGO1_"P" D S PSGORD=""
- . D EN21 K CONT D Q:$G(PSGOEA)["^"
- .. W !!,"Press RETURN to continue or '^' to exit: " S PN=$G(PN)+2 R CONT:DTIME W @IOF S:CONT["^" PSGOEA="^",PSGPR=1,PSJPR=1
- I PSGORD="" S PSGOEA="^" Q
- EN21 ;
- N PSIVFLG S PSIVFLG=0 I PSGORD["P" S PSIVFLG=$P(^PS(53.1,+PSGORD,0),"^",4) S PSIVFLG=$S(PSIVFLG="F":1,PSIVFLG="I":1,1:0)
- S NF=$S(PSGORD["P":1,PSGORD["N":1,1:0)
- S (FL,Y)="",$P(FL,"-",71)="",F="^PS("_$S(NF:"53.1,",(PSGORD["V"):"55,"_PSGP_",""IV"",",1:"55,"_PSGP_",5,")_+PSGORD_","
- S PNM=$G(PSGP(0)) S:PNM="" PNM=$P($G(^DPT(PSGP,0)),"^")
- Q:($G(@(F_"0)"))="")
- I $G(PSJINHIS) D PSJINHIS(1,.PSJCHTO) Q
- DONE ;
- K AND,D,DRG1,DRG2,AT,DO,DRG,EB,F,FD,FL,HSM,INS,LID,MR,ND4,OD,PN,PR,PSGID,PSGOD,R,SCH,SCT,SI,SIG,SM,ST,STD,UD,X,XU,Y,DONE,NF, Q
- Q
- ;
- PSJINHIS(PSJINHIS,PSJCHTO) ;
- I '$G(PSJHDRF) S PSJHDRF=1 N DASH S $P(DASH,"-",75)="-" D
- .I $E(IOST)="C" D FULL^VALM1 W @IOF
- .W !?25,"Instructions History",!,DASH S PN=$G(PN)+2
- N AND,AND2,PX S PX=""
- N INDENT1,INDENT2 S INDENT1=2,INDENT2=5
- I '$G(PSJPRCOM) D GETPRCOM Q:($G(PX)["^")
- D ENA Q:($G(PX)["^")
- Q:$G(PSJCHTO)=2
- I $G(PSGORD)["V"!$G(PSIVFLG) D PSGOPI Q
- D PSGSI
- Q
- ;
- PSGSI ;
- N SI,Q,QQ,QQQ S SI=$S(($G(PSGORD)["P"):$P($G(^PS(53.1,+PSGORD,6)),"^"),($G(PSGORD)["U"):$P($G(^PS(55,PSGP,5,+PSGORD,6)),"^"),1:"")
- N SIL S SIL=$$GETSIOPI^PSJBCMA5(PSGP,PSGORD,1) I SIL!(SI]"") D
- .Q:($G(PX)["^")
- .I '$G(PSJCHTO) N PSJUDGL,PSJUDPH S PSJUDGL=$S($G(PSGORD)["P":"^PS(53.1,+PSGORD,",$G(PSGORD)["U":"^PS(55,PSGP,5,+PSGORD,",1:"") D
- ..I '$G(AND) N AND S AND=$P(@(PSJUDGL_"0)"),"^",16) S PSJUDPH=@(PSJUDGL_"4)") S $P(AND,"^",2)=$S($P(PSJUDPH,"^",3):$P(PSJUDPH,"^",3),$P(PSJUDPH,"^",7):$P(PSJUDPH,"^",7),1:"")
- ..D:$G(PN)>PSJFULL NPAGE W !!,"Date: ",$$ENDTC^PSGMI(+AND) S PN=$G(PN)+3 W ?28,"User: ",$$ENNPN^PSGMI($P(AND,"^",2)),!?INDENT1,"SPECIAL INSTRUCTIONS changed" D
- ...W !?INDENT1,"From: ''",! S PSJCHTO=1 S PN=$G(PN)+2
- .I SI]"",'SIL W !?INDENT1,"To:",!?INDENT2 S PSJCHTO=2,PN=$G(PN)+2 D Q
- ..S QQQ="" F Q=1:1:$L(SI," ") S QQ=$P(SI," ",Q) W:($L(QQQ_" "_QQ)>72) ! W QQ," " S:($L(QQQ_" "_QQ)>72) QQQ="" S QQQ=QQQ_" "_QQ
- .I $G(PSJCHTO)=2,$D(TMPTO(DFN,1)) W !?INDENT1,"From: " S PSJCHTO=1,PN=$G(PN)+1 N TMPTOLN S TMPTOLN=0 F S TMPTOLN=$O(TMPTO(DFN,TMPTOLN)) Q:'TMPTOLN!(PX["^") W !?INDENT2,TMPTO(DFN,TMPTOLN) S PN=PN+1 D:($G(PN)>PSJFULL) NPAGE
- .Q:'$G(PSJSYSP) N LNTXT S LNTXT=0 F S LNTXT=$O(^TMP("PSJBCMA5",$J,PSGP,PSGORD,LNTXT)) Q:'LNTXT D
- ..I LNTXT=1 W !?INDENT1,"To:" S PSJCHTO=2 S PN=$G(PN)+1
- ..W !?INDENT2,$G(^TMP("PSJBCMA5",$J,PSGP,PSGORD,LNTXT)) S PN=$G(PN)+1 K:LNTXT=1 TMPTO S TMPTO(DFN,LNTXT)=^(LNTXT)
- Q
- ;
- PSGOPI ;
- N DT,USR,TXTLN,POPIL,POPI S POPI=$S($G(PSGORD)["V":$P($G(^PS(55,PSGP,"IV",+PSGORD,3)),"^"),$G(PSGORD)["P":$P($G(^PS(53.1,+PSGORD,9)),"^",2),1:"")
- S POPIL=$$GETSIOPI^PSJBCMA5(PSGP,PSGORD,1) I POPIL!(POPI]"") D
- .Q:($G(PX)["^")
- .I '$G(PSJCHTO) S $P(AND,"^")=$S(PSGORD["V":$P($G(^PS(55,PSGP,"IV",+PSGORD,2,1)),"^"),PSGORD["P":$P($G(^PS(53.1,+PSGORD,0)),"^",16),1:"") D
- ..S $P(AND,"^",2)=$S(PSGORD["V":$P($G(^PS(55,PSGP,"IV",+PSGORD,4)),"^",4),PSGORD["P":$P($G(^PS(53.1,+PSGORD,4)),"^",7),1:"")
- ..D:($G(PN)>PSJFULL) NPAGE W !!,"Date: ",$$ENDTC^PSGMI(+AND) S PN=$G(PN)+2 W ?28,"User: ",$$ENNPN^PSGMI($P(AND,"^",2)),!,"OTHER PRINT INFO changed" D
- ...W !?INDENT1,"From: ",!?INDENT2,"""""",! S PSJCHTO=1 S PN=$G(PN)+4
- .I $G(PSJCHTO)=2,$D(TMPTO(DFN,1)) W !?INDENT1,"From: " S PSJCHTO=1,PN=$G(PN)+1 N TMPTOLN S TMPTOLN=0 F S TMPTOLN=$O(TMPTO(DFN,TMPTOLN)) Q:'TMPTOLN!(PX["^") W !?INDENT2,TMPTO(DFN,TMPTOLN) S PN=PN+1 D:($G(PN)>PSJFULL) NPAGE
- .S TXTLN=0 F S TXTLN=$O(^TMP("PSJBCMA5",$J,PSGP,PSGORD,TXTLN)) Q:'TXTLN!($G(PX)["^") D
- ..I (TXTLN=1) W !?INDENT1,"To:" S PN=$G(PN)+1
- ..W !?INDENT2,^TMP("PSJBCMA5",$J,PSGP,PSGORD,TXTLN) S PN=$G(PN)+1,PSJCHTO=2 K:TXTLN=1 TMPTO S TMPTO(DFN,TXTLN)=^(TXTLN) D:($G(PN)>PSJFULL) NPAGE
- Q
- ENA ;
- I PSGORD["U" F Q=0:0 S Q=$O(^PS(55,PSGP,5,+PSGORD,9,Q)) Q:'Q!(PX["^") I $D(^(Q,0)) S AND=^(0) D:($G(PN)>PSJFULL) NPAGE Q:PX["^" D AL1
- I PSGORD["P" F Q=0:0 S Q=$O(^PS(53.1,+PSGORD,"A",Q)) Q:'Q!(PX["^") I $D(^(Q,0)) S AND=^(0) D:($G(PN)>PSJFULL) NPAGE Q:PX["^" D AL1
- I PSGORD["V" S Q=0 F S Q=$O(^PS(55,PSGP,"IV",+PSGORD,"A",Q)) Q:'Q!(PX["^") D:($G(PN)>PSJFULL) NPAGE Q:PX["^" S AND2=$G(^(Q,1,1,0)) I ($G(AND2)["OTHER PRINT INFO") D
- .S AND=$G(^PS(55,PSGP,"IV",+PSGORD,"A",Q,0)) D:($G(PN)>PSJFULL) NPAGE D AL1
- I ($G(PX)["^") S DONE=1
- Q
- AL1 ; Activity Logs
- S UD=$P(AND,"^",3)
- I AND["SPECIAL INSTRUCTIONS" D Q
- .I ($G(PSGORD)["U") D
- ..N LAST,Q2 S Q2=0 F S Q2=$O(^PS(55,DFN,5,+PSGORD,9,Q,Q2)) Q:'Q2!(PX["^") N Q3 S Q3=0 F S Q3=$O(^PS(55,DFN,5,+PSGORD,9,Q,Q2,Q3)) Q:'Q3!(PX["^") D
- ...S LAST=$G(LAST)+1
- ...I ($G(PSJCHTO)<2),(Q3=1),(Q2=1) D
- ....I '$G(PSJCHTO) D:($G(PN)>PSJFULL) NPAGE Q:($G(PX)["^") D DATUSR(+AND,$P(AND,"^",2),"SPECIAL INSTRUCTIONS changed")
- ....W !?INDENT1,"To:" S PN=$G(PN)+1 N TMPQ3 S TMPQ3=0 F S TMPQ3=$O(^PS(55,DFN,5,+PSGORD,9,Q,Q2,TMPQ3)) Q:'TMPQ3!(PX["^") W !?INDENT2,^PS(55,DFN,5,+PSGORD,9,Q,Q2,TMPQ3,0) S PN=$G(PN)+1 S PSJCHTO=2 K:TMPQ3=1 TMPTO S TMPTO(DFN,TMPQ3)=^(0)
- ...Q:PX["^" D:($G(PN)>PSJFULL) NPAGE Q:PX["^"
- ...I (Q3=1),(Q2=1) D:($G(PN)>PSJFULL) NPAGE Q:($G(PX)["^") D DATUSR(+AND,$P(AND,"^",2),"SPECIAL INSTRUCTIONS changed")
- ...Q:($G(PX)["^") I (Q3=1) W !?INDENT1,$S(PSJCHTO=2:"From: ",PSJCHTO=1:"To:",1:"") S PSJCHTO=$S(PSJCHTO=2:1,1:2) S PN=$G(PN)+1 D:($G(PN)>PSJFULL)
- ...W !?INDENT2,^PS(55,DFN,5,+PSGORD,9,Q,Q2,Q3,0) S PN=$G(PN)+1 K:Q3=1 TMPTO S:PSJCHTO=2 TMPTO(DFN,Q3)=^(0)
- ..I '$G(LAST) N Q2TM,Q0TM S Q2TM=$P($G(^PS(55,DFN,5,+PSGORD,9,Q,0)),"^"),Q0TM=$P($G(^PS(55,DFN,5,+PSGORD,9,1,0)),"^") Q:($$FMDIFF^XLFDT(Q2TM,Q0TM,2)>0) D
- ...D CPYPC(DFN,PSGORD,Q)
- .I ($G(PSGORD)["P") D
- ..I '$O(^PS(53.1,+PSGORD,"A",Q,0)) D
- ...D:($G(PN)>PSJFULL) NPAGE Q:PX["^" D DATUSR(+AND,$P(AND,"^",2),"SPECIAL INSTRUCTIONS changed")
- ...N FROM S FROM=$P(AND,"^",5) W !?INDENT1,"From: " S PN=$G(PN)+1 S PSJCHTO=1 D
- ....I FROM]"" W !?INDENT2,FROM S PN=$G(PN)+1 Q
- ....I $D(TMPTO(DFN,1)) N TMPTOLN S TMPTOLN=0 F S TMPTOLN=$O(TMPTO(DFN,TMPTOLN)) Q:'TMPTOLN!(PX["^") W !?INDENT2,TMPTO(DFN,TMPTOLN) S PN=PN+1 D:($G(PN)>PSJFULL) NPAGE
- ..N QB S QB=0 F S QB=$O(^PS(53.1,+PSGORD,"A",Q,QB)) Q:'QB!(PX["^") N Q2 S Q2=0 F S Q2=$O(^PS(53.1,+PSGORD,"A",Q,QB,Q2)) Q:'Q2!(PX["^") D
- ...I ($G(PSJCHTO)<2),(Q2=1),(QB=1) W !?INDENT1,"To:" S PN=$G(PN)+1,PSJCHTO=2 D
- ....N TMPQ2 S TMPQ2=0 F S TMPQ2=$O(^PS(53.1,+PSGORD,"A",Q,QB,TMPQ2)) Q:'TMPQ2!(PX["^") W !?INDENT2,^PS(53.1,+PSGORD,"A",Q,QB,TMPQ2,0) S PN=$G(PN)+1 K:TMPQ2=1 TMPTO S TMPTO(DFN,TMPQ2)=^(0)
- ...Q:PX["^"
- ...I (Q2=1),(QB=1) D:($G(PN)>PSJFULL) NPAGE Q:PX["^" D DATUSR(+AND,$P(AND,"^",2),"SPECIAL INSTRUCTIONS changed")
- ...I (Q2=1) W !?INDENT1,$S(PSJCHTO=2:"From: ",PSJCHTO=2:"To:",1:"") S PSJCHTO=$S(PSJCHTO=2:1,1:2) S PN=$G(PN)+1
- ...Q:PX["^" W !?INDENT2,^PS(53.1,+PSGORD,"A",Q,QB,Q2,0) S PN=$G(PN)+1 D:($G(PN)>PSJFULL) NPAGE Q:PX["^" K:Q2=1 TMPTO S:PSJCHTO=2 TMPTO(DFN,Q2)=^(0)
- I $G(AND2)["OTHER PRINT INFO"!($G(AND)["OTHER PRINT INFO") S PSJIVFLG=1 D
- .I ($G(PSGORD)["V") N Q2 F Q2=2,3 Q:(PX["^") N Q3 S Q3=0 F S Q3=$O(^PS(55,DFN,"IV",+PSGORD,"A",Q,Q2,Q3)) Q:'Q3!(PX["^") D
- ..I ($G(PSJCHTO)=1),Q2=2,Q3=1 D
- ...N TMPQ3 S TMPQ3=0 F S TMPQ3=$O(^PS(55,DFN,"IV",+PSGORD,"A",Q,Q2,TMPQ3)) Q:'TMPQ3!(PX["^") D
- ....D:($G(PN)>PSJFULL) NPAGE W:TMPQ3=1 !?INDENT1,"To: " W !?INDENT2,^PS(55,DFN,"IV",+PSGORD,"A",Q,Q2,TMPQ3,0) K:TMPQ3=1 TMPTO S TMPTO(DFN,TMPQ3)=^(0)
- ....S PN=PN+2,PSJCHTO=2 D:($G(PN)>PSJFULL) NPAGE Q:PX["^"
- ..Q:PX["^"
- ..I Q3=1,($G(PSJCHTO)'=1) D:($G(PN)>PSJFULL) NPAGE Q:PX["^" D Q:($G(PX)["^")
- ...D DATUSR($P(AND,"^",5),$P(AND,"^",3),"OTHER PRINT INFO changed")
- ...;W !!,"Date: ",$$ENDTC^PSGMI($P(AND,"^",5)) W ?28,"User: ",$$ENNPN^PSGMI($P(AND,"^",3)),!,"OTHER PRINT INFO changed" S PN=$G(PN)+3
- ..I Q3=1,Q2=3,'$G(PSJCHTO) W !?INDENT1,"From: """"" S PSJCHTO=1,PN=$G(PN)+1
- ..I Q3=1,Q2=3,PSJCHTO=2,$D(TMPTO(DFN,1)) W !?INDENT1,"From: " S PSJCHTO=1,PN=$G(PN)+1 N TMPTOLN S TMPTOLN=0 F S TMPTOLN=$O(TMPTO(DFN,TMPTOLN)) Q:'TMPTOLN!(PX["^") W !?INDENT2,TMPTO(DFN,TMPTOLN) S PN=PN+1 D:($G(PN)>PSJFULL) NPAGE
- ..Q:(PX["^") I Q3=1 W !?INDENT1,$S(PSJCHTO'=1:"From: ",PSJCHTO=1:"To: ",1:"") S PSJCHTO=$S(PSJCHTO=1:2,1:1) S PN=PN+1 Q:PX["^"
- ..Q:PX["^" W !?INDENT2,^PS(55,DFN,"IV",+PSGORD,"A",Q,Q2,Q3,0) K:Q3=1 TMPTO S:PSJCHTO=2 TMPTO(DFN,Q3)=^(0) S PN=PN+1 D:($G(PN)>PSJFULL) NPAGE Q:PX["^"
- .I $G(PN)>PSJFULL D NPAGE Q:(PX["^")
- .I ($G(PSGORD)["P") D:($G(PN)>PSJFULL) NPAGE Q:PX["^" D
- ..I ($G(PSJCHTO)'=1) W !,"Date: ",$$ENDTC^PSGMI(+AND) W ?28,"User: ",$$ENNPN^PSGMI($P(AND,"^",2)),!,"OTHER PRINT INFO changed" S PN=$G(PN)+2
- ..I '$G(PSJCHTO) N FROM S FROM=$P(AND,"^",5),FROM=$S(FROM]"":FROM,1:"""""") W !?INDENT1,"From: ",!?INDENT2,FROM S PSJCHTO=1,PN=$G(PN)+1
- ..N QB S QB=0 F S QB=$O(^PS(53.1,+PSGORD,"A",Q,QB)) Q:'QB!($G(PX)["^") N Q2 S Q2=0 F S Q2=$O(^PS(53.1,+PSGORD,"A",Q,QB,Q2)) Q:'Q2!($G(PX)["^") D
- ...I ($G(PSJCHTO)<2),(Q2=1),(QB=1) D:($G(PN)>PSJFULL) NPAGE W !?INDENT1,"To: " S PN=$G(PN)+2,PSJCHTO=2 D W !
- ....N TMPQ2 S TMPQ2=0 F S TMPQ2=$O(^PS(53.1,+PSGORD,"A",Q,QB,TMPQ2)) Q:'TMPQ2!(PX["^") W !?INDENT2,^PS(53.1,+PSGORD,"A",Q,QB,TMPQ2,0) S PN=$G(PN)+1 D:($G(PN)>PSJFULL) NPAGE
- ...I (Q2=1),(QB=1) D DATUSR($P(AND,"^",5),$P(AND,"^",3),"OTHER PRINT INFO changed") ; W !,"Date: ",$$ENDTC^PSGMI(+AND) W:$S(UD'?4N:1,1:$E(UD,1,2)'=10) ?28,"User: ",$$ENNPN^PSGMI($P(AND,"^",2)),!,"OTHER PRINT INFO changed" S PN=$G(PN)+2
- ...I (Q2=1) D:($G(PN)>PSJFULL) NPAGE W !?INDENT1,$S(QB=1:"From: ",QB=2:"To: ",1:"") S PSJCHTO=$S(QB=2:2,1:1) S PN=$G(PN)+1
- ...Q:($G(PX)["^") W !?INDENT2,^PS(53.1,+PSGORD,"A",Q,QB,Q2,0) S PN=$G(PN)+1 D:($G(PN)>PSJFULL) NPAGE Q:PX["^"
- ..I ($G(PN)>PSJFULL) D NPAGE
- Q
- ;
- GETPRCOM ; Get provider comments
- N PROVLN
- I $G(PSGORD)["V" S PROVLN=0 F S PROVLN=$O(^PS(55,DFN,"IV",+PSGORD,5,PROVLN)) Q:'PROVLN!($G(PX)["^") D
- .I (PROVLN=1) S DT=$P($G(^PS(55,DFN,"IV",+PSGORD,2)),"^"),USR=$P($G(^PS(55,DFN,"IV",+PSGORD,0)),"^",6) D DATUSR(DT,USR,"PROVIDER COMMENTS:") S PSJPRCOM=1
- .W !?INDENT2,^PS(55,DFN,"IV",+PSGORD,5,PROVLN,0) S PN=$G(PN)+1 I ($G(PN)>PSJFULL) D NPAGE
- I $G(PSGORD)["U" S PROVLN=0 F S PROVLN=$O(^PS(55,DFN,5,+PSGORD,12,PROVLN)) Q:'PROVLN!($G(PX)["^") D
- .I (PROVLN=1) S DT=$P($G(^PS(55,DFN,5,+PSGORD,0)),"^",16),USR=$P($G(^PS(55,DFN,5,+PSGORD,0)),"^",2) D DATUSR(DT,USR,"PROVIDER COMMENTS:") S PSJPRCOM=1
- .W !?INDENT2,^PS(55,DFN,5,+PSGORD,12,PROVLN,0) S PN=$G(PN)+1 I ($G(PN)>PSJFULL) D NPAGE
- I $G(PSGORD)["P" S PROVLN=0 F S PROVLN=$O(^PS(53.1,+PSGORD,12,PROVLN)) Q:'PROVLN!($G(PX)["^") D
- .I (PROVLN=1) S DT=$P($G(^PS(53.1,+PSGORD,0)),"^",16),USR=$P($G(^PS(53.1,+PSGORD,0)),"^",2) D DATUSR(DT,USR,"PROVIDER COMMENTS:") S PSJPRCOM=1
- .W !?INDENT2,^PS(53.1,+PSGORD,12,PROVLN,0) S PN=$G(PN)+1 I ($G(PN)>PSJFULL) D NPAGE
- D:($G(PN)>PSJFULL) NPAGE
- Q
- NPAGE ; Pause
- Q:$G(PSJPTR)
- I PN<PSJFULL F PN=PN:1:PSJFULL-1 W !
- I $E(IOST)="C" R !!,"Enter '^' to stop, or press RETURN to continue.",PX:DTIME D
- .I $G(PX)["^" S DONE=1
- .D FULL^VALM1 W @IOF
- W !?25,"Instructions History" S PN=1
- N DASH S $P(DASH,"-",75)="-" W !,DASH S PN=$G(PN)+1
- Q
- ;
- DATUSR(DT,USR,TXT) ;
- I $G(PN)>(PSJFULL-5) D NPAGE Q:(PX["^")
- N DAT,USER
- S DAT=$$ENDTC^PSSGMI(DT),USER=$$ENNPN^PSGMI(USR)
- W !!,"Date: ",DAT,?28,"User: ",USER,!,TXT S PN=$G(PN)+3
- Q
- ;
- CPYPC(DFN,PSGORD,Q) ; Handle Special Instructions copied in from Provider Comments during finishing
- Q:$O(^PS(55,DFN,5,+PSGORD,9,Q,0))
- N PS55ND0 S PS55ND0=$G(^PS(55,DFN,5,+PSGORD,0))
- N PRVORD S PRVORD=$P(PS55ND0,"^",25) Q:'PRVORD
- N PRVSI S PRVSI=$$GETSIOPI^PSJBCMA5(DFN,PRVORD,1) Q:'PRVSI
- I ($G(PSJCHTO)=2) D
- .D:($G(PN)>PSJFULL) NPAGE Q:($G(PX)["^") D DATUSR(+AND,$P(AND,"^",2),"SPECIAL INSTRUCTIONS changed")
- .W !?INDENT1,"From:" S PN=$G(PN)+1 N TMPQ3 S TMPQ3=0 F S TMPQ3=$O(^TMP("PSJBCMA5",$J,DFN,PRVORD,TMPQ3)) Q:'TMPQ3!(PX["^") D
- ..W !?INDENT2,^TMP("PSJBCMA5",$J,DFN,PRVORD,TMPQ3) S PN=$G(PN)+1 S PSJCHTO=2 K:TMPQ3=1 TMPTO S TMPTO(DFN,TMPQ3)=^TMP("PSJBCMA5",$J,DFN,PRVORD,TMPQ3)
- .S PSJCHTO=1
- Q:PX["^" D:($G(PN)>PSJFULL) NPAGE Q:PX["^"
- D:($G(PN)>PSJFULL) NPAGE Q:($G(PX)["^") D DATUSR(+AND,$P(AND,"^",2),"SPECIAL INSTRUCTIONS changed")
- Q:($G(PX)["^") W !?INDENT1,$S(PSJCHTO=2:"From: ",PSJCHTO=1:"To:",1:"") S PSJCHTO=$S(PSJCHTO=2:1,1:2) S PN=$G(PN)+1
- N TOSI,FOUNDTO S TOSI=Q F Q:$G(FOUNDTO) S TOSI=$O(^PS(55,DFN,5,+PSGORD,9,TOSI)) Q:'TOSI I $G(^PS(55,DFN,5,+PSGORD,9,TOSI,0))["SPECIAL INSTRUCTIONS" S FOUNDTO=TOSI
- I $G(FOUNDTO) S TOSI=0 F S TOSI=$O(^PS(55,DFN,5,+PSGORD,9,FOUNDTO,1,TOSI)) Q:'TOSI D
- .W !?INDENT2,^PS(55,DFN,5,+PSGORD,9,FOUNDTO,1,TOSI,0) S PN=$G(PN)+1 K:TOSI=1 TMPTO S:PSJCHTO=2 TMPTO(DFN,TOSI)=^(0)
- Q:$G(FOUNDTO)
- S TOSI=0 F S TOSI=$O(^PS(55,DFN,5,+PSGORD,15,TOSI)) Q:'TOSI W !?INDENT2,$G(^(TOSI,0))
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJINVW 13358 printed Feb 18, 2025@23:33:35 Page 2
- PSJINVW ;BIR/CML3-INSTRUCTION HISTORY ;17 SEP 97 / 1:41 PM
- +1 ;;5.0;INPATIENT MEDICATIONS;**267,275**;16 DEC 97;Build 157
- +2 ;
- +3 ; Reference to ^PS(50.7 is supported by DBIA# 2180.
- +4 ; Reference to ^PS(51.2 is supported by DBIA# 2178.
- +5 ; Reference to ^PS(55 is supported by DBIA# 2191.
- +6 ;
- EN0(PSJINHIS,PSJCHTO) ;
- +1 NEW PNM,PSJFULL
- SET PSJFULL=20
- +2 DO EN2
- QUIT
- +3 QUIT
- EN2 ;
- +1 IF PSGORD=+PSGORD
- NEW PSGO,PSGO1
- SET PSGO=PSGORD
- SET PSGO1=0
- FOR
- SET PSGO1=$ORDER(^PS(53.1,"ACX",PSGO,PSGO1))
- if 'PSGO1
- QUIT
- if $GET(PSGOEA)["^"
- QUIT
- SET PSGORD=PSGO1_"P"
- Begin DoDot:1
- +2 DO EN21
- KILL CONT
- Begin DoDot:2
- +3 WRITE !!,"Press RETURN to continue or '^' to exit: "
- SET PN=$GET(PN)+2
- READ CONT:DTIME
- WRITE @IOF
- if CONT["^"
- SET PSGOEA="^"
- SET PSGPR=1
- SET PSJPR=1
- End DoDot:2
- if $GET(PSGOEA)["^"
- QUIT
- End DoDot:1
- SET PSGORD=""
- +4 IF PSGORD=""
- SET PSGOEA="^"
- QUIT
- EN21 ;
- +1 NEW PSIVFLG
- SET PSIVFLG=0
- IF PSGORD["P"
- SET PSIVFLG=$PIECE(^PS(53.1,+PSGORD,0),"^",4)
- SET PSIVFLG=$SELECT(PSIVFLG="F":1,PSIVFLG="I":1,1:0)
- +2 SET NF=$SELECT(PSGORD["P":1,PSGORD["N":1,1:0)
- +3 SET (FL,Y)=""
- SET $PIECE(FL,"-",71)=""
- SET F="^PS("_$SELECT(NF:"53.1,",(PSGORD["V"):"55,"_PSGP_",""IV"",",1:"55,"_PSGP_",5,")_+PSGORD_","
- +4 SET PNM=$GET(PSGP(0))
- if PNM=""
- SET PNM=$PIECE($GET(^DPT(PSGP,0)),"^")
- +5 if ($GET(@(F_"0)"))="")
- QUIT
- +6 IF $GET(PSJINHIS)
- DO PSJINHIS(1,.PSJCHTO)
- QUIT
- DONE ;
- +1 KILL AND,D,DRG1,DRG2,AT,DO,DRG,EB,F,FD,FL,HSM,INS,LID,MR,ND4,OD,PN,PR,PSGID,PSGOD,R,SCH,SCT,SI,SIG,SM,ST,STD,UD,X,XU,Y,DONE,NF,
- QUIT
- +2 QUIT
- +3 ;
- PSJINHIS(PSJINHIS,PSJCHTO) ;
- +1 IF '$GET(PSJHDRF)
- SET PSJHDRF=1
- NEW DASH
- SET $PIECE(DASH,"-",75)="-"
- Begin DoDot:1
- +2 IF $EXTRACT(IOST)="C"
- DO FULL^VALM1
- WRITE @IOF
- +3 WRITE !?25,"Instructions History",!,DASH
- SET PN=$GET(PN)+2
- End DoDot:1
- +4 NEW AND,AND2,PX
- SET PX=""
- +5 NEW INDENT1,INDENT2
- SET INDENT1=2
- SET INDENT2=5
- +6 IF '$GET(PSJPRCOM)
- DO GETPRCOM
- if ($GET(PX)["^")
- QUIT
- +7 DO ENA
- if ($GET(PX)["^")
- QUIT
- +8 if $GET(PSJCHTO)=2
- QUIT
- +9 IF $GET(PSGORD)["V"!$GET(PSIVFLG)
- DO PSGOPI
- QUIT
- +10 DO PSGSI
- +11 QUIT
- +12 ;
- PSGSI ;
- +1 NEW SI,Q,QQ,QQQ
- SET SI=$SELECT(($GET(PSGORD)["P"):$PIECE($GET(^PS(53.1,+PSGORD,6)),"^"),($GET(PSGORD)["U"):$PIECE($GET(^PS(55,PSGP,5,+PSGORD,6)),"^"),1:"")
- +2 NEW SIL
- SET SIL=$$GETSIOPI^PSJBCMA5(PSGP,PSGORD,1)
- IF SIL!(SI]"")
- Begin DoDot:1
- +3 if ($GET(PX)["^")
- QUIT
- +4 IF '$GET(PSJCHTO)
- NEW PSJUDGL,PSJUDPH
- SET PSJUDGL=$SELECT($GET(PSGORD)["P":"^PS(53.1,+PSGORD,",$GET(PSGORD)["U":"^PS(55,PSGP,5,+PSGORD,",1:"")
- Begin DoDot:2
- +5 IF '$GET(AND)
- NEW AND
- SET AND=$PIECE(@(PSJUDGL_"0)"),"^",16)
- SET PSJUDPH=@(PSJUDGL_"4)")
- SET $PIECE(AND,"^",2)=$SELECT($PIECE(PSJUDPH,"^",3):$PIECE(PSJUDPH,"^",3),$PIECE(PSJUDPH,"^",7):$PIECE(PSJUDPH,"^",7),1:"")
- +6 if $GET(PN)>PSJFULL
- DO NPAGE
- WRITE !!,"Date: ",$$ENDTC^PSGMI(+AND)
- SET PN=$GET(PN)+3
- WRITE ?28,"User: ",$$ENNPN^PSGMI($PIECE(AND,"^",2)),!?INDENT1,"SPECIAL INSTRUCTIONS changed"
- Begin DoDot:3
- +7 WRITE !?INDENT1,"From: ''",!
- SET PSJCHTO=1
- SET PN=$GET(PN)+2
- End DoDot:3
- End DoDot:2
- +8 IF SI]""
- IF 'SIL
- WRITE !?INDENT1,"To:",!?INDENT2
- SET PSJCHTO=2
- SET PN=$GET(PN)+2
- Begin DoDot:2
- +9 SET QQQ=""
- FOR Q=1:1:$LENGTH(SI," ")
- SET QQ=$PIECE(SI," ",Q)
- if ($LENGTH(QQQ_" "_QQ)>72)
- WRITE !
- WRITE QQ," "
- if ($LENGTH(QQQ_" "_QQ)>72)
- SET QQQ=""
- SET QQQ=QQQ_" "_QQ
- End DoDot:2
- QUIT
- +10 IF $GET(PSJCHTO)=2
- IF $DATA(TMPTO(DFN,1))
- WRITE !?INDENT1,"From: "
- SET PSJCHTO=1
- SET PN=$GET(PN)+1
- NEW TMPTOLN
- SET TMPTOLN=0
- FOR
- SET TMPTOLN=$ORDER(TMPTO(DFN,TMPTOLN))
- if 'TMPTOLN!(PX["^")
- QUIT
- WRITE !?INDENT2,TMPTO(DFN,TMPTOLN)
- SET PN=PN+1
- if ($GET(PN)>PSJFULL)
- DO NPAGE
- +11 if '$GET(PSJSYSP)
- QUIT
- NEW LNTXT
- SET LNTXT=0
- FOR
- SET LNTXT=$ORDER(^TMP("PSJBCMA5",$JOB,PSGP,PSGORD,LNTXT))
- if 'LNTXT
- QUIT
- Begin DoDot:2
- +12 IF LNTXT=1
- WRITE !?INDENT1,"To:"
- SET PSJCHTO=2
- SET PN=$GET(PN)+1
- +13 WRITE !?INDENT2,$GET(^TMP("PSJBCMA5",$JOB,PSGP,PSGORD,LNTXT))
- SET PN=$GET(PN)+1
- if LNTXT=1
- KILL TMPTO
- SET TMPTO(DFN,LNTXT)=^(LNTXT)
- End DoDot:2
- End DoDot:1
- +14 QUIT
- +15 ;
- PSGOPI ;
- +1 NEW DT,USR,TXTLN,POPIL,POPI
- SET POPI=$SELECT($GET(PSGORD)["V":$PIECE($GET(^PS(55,PSGP,"IV",+PSGORD,3)),"^"),$GET(PSGORD)["P":$PIECE($GET(^PS(53.1,+PSGORD,9)),"^",2),1:"")
- +2 SET POPIL=$$GETSIOPI^PSJBCMA5(PSGP,PSGORD,1)
- IF POPIL!(POPI]"")
- Begin DoDot:1
- +3 if ($GET(PX)["^")
- QUIT
- +4 IF '$GET(PSJCHTO)
- SET $PIECE(AND,"^")=$SELECT(PSGORD["V":$PIECE($GET(^PS(55,PSGP,"IV",+PSGORD,2,1)),"^"),PSGORD["P":$PIECE($GET(^PS(53.1,+PSGORD,0)),"^",16),1:"")
- Begin DoDot:2
- +5 SET $PIECE(AND,"^",2)=$SELECT(PSGORD["V":$PIECE($GET(^PS(55,PSGP,"IV",+PSGORD,4)),"^",4),PSGORD["P":$PIECE($GET(^PS(53.1,+PSGORD,4)),"^",7),1:"")
- +6 if ($GET(PN)>PSJFULL)
- DO NPAGE
- WRITE !!,"Date: ",$$ENDTC^PSGMI(+AND)
- SET PN=$GET(PN)+2
- WRITE ?28,"User: ",$$ENNPN^PSGMI($PIECE(AND,"^",2)),!,"OTHER PRINT INFO changed"
- Begin DoDot:3
- +7 WRITE !?INDENT1,"From: ",!?INDENT2,"""""",!
- SET PSJCHTO=1
- SET PN=$GET(PN)+4
- End DoDot:3
- End DoDot:2
- +8 IF $GET(PSJCHTO)=2
- IF $DATA(TMPTO(DFN,1))
- WRITE !?INDENT1,"From: "
- SET PSJCHTO=1
- SET PN=$GET(PN)+1
- NEW TMPTOLN
- SET TMPTOLN=0
- FOR
- SET TMPTOLN=$ORDER(TMPTO(DFN,TMPTOLN))
- if 'TMPTOLN!(PX["^")
- QUIT
- WRITE !?INDENT2,TMPTO(DFN,TMPTOLN)
- SET PN=PN+1
- if ($GET(PN)>PSJFULL)
- DO NPAGE
- +9 SET TXTLN=0
- FOR
- SET TXTLN=$ORDER(^TMP("PSJBCMA5",$JOB,PSGP,PSGORD,TXTLN))
- if 'TXTLN!($GET(PX)["^")
- QUIT
- Begin DoDot:2
- +10 IF (TXTLN=1)
- WRITE !?INDENT1,"To:"
- SET PN=$GET(PN)+1
- +11 WRITE !?INDENT2,^TMP("PSJBCMA5",$JOB,PSGP,PSGORD,TXTLN)
- SET PN=$GET(PN)+1
- SET PSJCHTO=2
- if TXTLN=1
- KILL TMPTO
- SET TMPTO(DFN,TXTLN)=^(TXTLN)
- if ($GET(PN)>PSJFULL)
- DO NPAGE
- End DoDot:2
- End DoDot:1
- +12 QUIT
- ENA ;
- +1 IF PSGORD["U"
- FOR Q=0:0
- SET Q=$ORDER(^PS(55,PSGP,5,+PSGORD,9,Q))
- if 'Q!(PX["^")
- QUIT
- IF $DATA(^(Q,0))
- SET AND=^(0)
- if ($GET(PN)>PSJFULL)
- DO NPAGE
- if PX["^"
- QUIT
- DO AL1
- +2 IF PSGORD["P"
- FOR Q=0:0
- SET Q=$ORDER(^PS(53.1,+PSGORD,"A",Q))
- if 'Q!(PX["^")
- QUIT
- IF $DATA(^(Q,0))
- SET AND=^(0)
- if ($GET(PN)>PSJFULL)
- DO NPAGE
- if PX["^"
- QUIT
- DO AL1
- +3 IF PSGORD["V"
- SET Q=0
- FOR
- SET Q=$ORDER(^PS(55,PSGP,"IV",+PSGORD,"A",Q))
- if 'Q!(PX["^")
- QUIT
- if ($GET(PN)>PSJFULL)
- DO NPAGE
- if PX["^"
- QUIT
- SET AND2=$GET(^(Q,1,1,0))
- IF ($GET(AND2)["OTHER PRINT INFO")
- Begin DoDot:1
- +4 SET AND=$GET(^PS(55,PSGP,"IV",+PSGORD,"A",Q,0))
- if ($GET(PN)>PSJFULL)
- DO NPAGE
- DO AL1
- End DoDot:1
- +5 IF ($GET(PX)["^")
- SET DONE=1
- +6 QUIT
- AL1 ; Activity Logs
- +1 SET UD=$PIECE(AND,"^",3)
- +2 IF AND["SPECIAL INSTRUCTIONS"
- Begin DoDot:1
- +3 IF ($GET(PSGORD)["U")
- Begin DoDot:2
- +4 NEW LAST,Q2
- SET Q2=0
- FOR
- SET Q2=$ORDER(^PS(55,DFN,5,+PSGORD,9,Q,Q2))
- if 'Q2!(PX["^")
- QUIT
- NEW Q3
- SET Q3=0
- FOR
- SET Q3=$ORDER(^PS(55,DFN,5,+PSGORD,9,Q,Q2,Q3))
- if 'Q3!(PX["^")
- QUIT
- Begin DoDot:3
- +5 SET LAST=$GET(LAST)+1
- +6 IF ($GET(PSJCHTO)<2)
- IF (Q3=1)
- IF (Q2=1)
- Begin DoDot:4
- +7 IF '$GET(PSJCHTO)
- if ($GET(PN)>PSJFULL)
- DO NPAGE
- if ($GET(PX)["^")
- QUIT
- DO DATUSR(+AND,$PIECE(AND,"^",2),"SPECIAL INSTRUCTIONS changed")
- +8 WRITE !?INDENT1,"To:"
- SET PN=$GET(PN)+1
- NEW TMPQ3
- SET TMPQ3=0
- FOR
- SET TMPQ3=$ORDER(^PS(55,DFN,5,+PSGORD,9,Q,Q2,TMPQ3))
- if 'TMPQ3!(PX["^")
- QUIT
- WRITE !?INDENT2,^PS(55,DFN,5,+PSGORD,9,Q,Q2,TMPQ3,0)
- SET PN=$GET(PN)+1
- SET PSJCHTO=2
- if TMPQ3=1
- KILL TMPTO
- SET TMPTO(DFN,TMPQ3)=^(0)
- End DoDot:4
- +9 if PX["^"
- QUIT
- if ($GET(PN)>PSJFULL)
- DO NPAGE
- if PX["^"
- QUIT
- +10 IF (Q3=1)
- IF (Q2=1)
- if ($GET(PN)>PSJFULL)
- DO NPAGE
- if ($GET(PX)["^")
- QUIT
- DO DATUSR(+AND,$PIECE(AND,"^",2),"SPECIAL INSTRUCTIONS changed")
- +11 if ($GET(PX)["^")
- QUIT
- IF (Q3=1)
- WRITE !?INDENT1,$SELECT(PSJCHTO=2:"From: ",PSJCHTO=1:"To:",1:"")
- SET PSJCHTO=$SELECT(PSJCHTO=2:1,1:2)
- SET PN=$GET(PN)+1
- if ($GET(PN)>PSJFULL)
- Begin DoDot:4
- End DoDot:4
- +12 WRITE !?INDENT2,^PS(55,DFN,5,+PSGORD,9,Q,Q2,Q3,0)
- SET PN=$GET(PN)+1
- if Q3=1
- KILL TMPTO
- if PSJCHTO=2
- SET TMPTO(DFN,Q3)=^(0)
- End DoDot:3
- +13 IF '$GET(LAST)
- NEW Q2TM,Q0TM
- SET Q2TM=$PIECE($GET(^PS(55,DFN,5,+PSGORD,9,Q,0)),"^")
- SET Q0TM=$PIECE($GET(^PS(55,DFN,5,+PSGORD,9,1,0)),"^")
- if ($$FMDIFF^XLFDT(Q2TM,Q0TM,2)>0)
- QUIT
- Begin DoDot:3
- +14 DO CPYPC(DFN,PSGORD,Q)
- End DoDot:3
- End DoDot:2
- +15 IF ($GET(PSGORD)["P")
- Begin DoDot:2
- +16 IF '$ORDER(^PS(53.1,+PSGORD,"A",Q,0))
- Begin DoDot:3
- +17 if ($GET(PN)>PSJFULL)
- DO NPAGE
- if PX["^"
- QUIT
- DO DATUSR(+AND,$PIECE(AND,"^",2),"SPECIAL INSTRUCTIONS changed")
- +18 NEW FROM
- SET FROM=$PIECE(AND,"^",5)
- WRITE !?INDENT1,"From: "
- SET PN=$GET(PN)+1
- SET PSJCHTO=1
- Begin DoDot:4
- +19 IF FROM]""
- WRITE !?INDENT2,FROM
- SET PN=$GET(PN)+1
- QUIT
- +20 IF $DATA(TMPTO(DFN,1))
- NEW TMPTOLN
- SET TMPTOLN=0
- FOR
- SET TMPTOLN=$ORDER(TMPTO(DFN,TMPTOLN))
- if 'TMPTOLN!(PX["^")
- QUIT
- WRITE !?INDENT2,TMPTO(DFN,TMPTOLN)
- SET PN=PN+1
- if ($GET(PN)>PSJFULL)
- DO NPAGE
- End DoDot:4
- End DoDot:3
- +21 NEW QB
- SET QB=0
- FOR
- SET QB=$ORDER(^PS(53.1,+PSGORD,"A",Q,QB))
- if 'QB!(PX["^")
- QUIT
- NEW Q2
- SET Q2=0
- FOR
- SET Q2=$ORDER(^PS(53.1,+PSGORD,"A",Q,QB,Q2))
- if 'Q2!(PX["^")
- QUIT
- Begin DoDot:3
- +22 IF ($GET(PSJCHTO)<2)
- IF (Q2=1)
- IF (QB=1)
- WRITE !?INDENT1,"To:"
- SET PN=$GET(PN)+1
- SET PSJCHTO=2
- Begin DoDot:4
- +23 NEW TMPQ2
- SET TMPQ2=0
- FOR
- SET TMPQ2=$ORDER(^PS(53.1,+PSGORD,"A",Q,QB,TMPQ2))
- if 'TMPQ2!(PX["^")
- QUIT
- WRITE !?INDENT2,^PS(53.1,+PSGORD,"A",Q,QB,TMPQ2,0)
- SET PN=$GET(PN)+1
- if TMPQ2=1
- KILL TMPTO
- SET TMPTO(DFN,TMPQ2)=^(0)
- End DoDot:4
- +24 if PX["^"
- QUIT
- +25 IF (Q2=1)
- IF (QB=1)
- if ($GET(PN)>PSJFULL)
- DO NPAGE
- if PX["^"
- QUIT
- DO DATUSR(+AND,$PIECE(AND,"^",2),"SPECIAL INSTRUCTIONS changed")
- +26 IF (Q2=1)
- WRITE !?INDENT1,$SELECT(PSJCHTO=2:"From: ",PSJCHTO=2:"To:",1:"")
- SET PSJCHTO=$SELECT(PSJCHTO=2:1,1:2)
- SET PN=$GET(PN)+1
- +27 if PX["^"
- QUIT
- WRITE !?INDENT2,^PS(53.1,+PSGORD,"A",Q,QB,Q2,0)
- SET PN=$GET(PN)+1
- if ($GET(PN)>PSJFULL)
- DO NPAGE
- if PX["^"
- QUIT
- if Q2=1
- KILL TMPTO
- if PSJCHTO=2
- SET TMPTO(DFN,Q2)=^(0)
- End DoDot:3
- End DoDot:2
- End DoDot:1
- QUIT
- +28 IF $GET(AND2)["OTHER PRINT INFO"!($GET(AND)["OTHER PRINT INFO")
- SET PSJIVFLG=1
- Begin DoDot:1
- +29 IF ($GET(PSGORD)["V")
- NEW Q2
- FOR Q2=2,3
- if (PX["^")
- QUIT
- NEW Q3
- SET Q3=0
- FOR
- SET Q3=$ORDER(^PS(55,DFN,"IV",+PSGORD,"A",Q,Q2,Q3))
- if 'Q3!(PX["^")
- QUIT
- Begin DoDot:2
- +30 IF ($GET(PSJCHTO)=1)
- IF Q2=2
- IF Q3=1
- Begin DoDot:3
- +31 NEW TMPQ3
- SET TMPQ3=0
- FOR
- SET TMPQ3=$ORDER(^PS(55,DFN,"IV",+PSGORD,"A",Q,Q2,TMPQ3))
- if 'TMPQ3!(PX["^")
- QUIT
- Begin DoDot:4
- +32 if ($GET(PN)>PSJFULL)
- DO NPAGE
- if TMPQ3=1
- WRITE !?INDENT1,"To: "
- WRITE !?INDENT2,^PS(55,DFN,"IV",+PSGORD,"A",Q,Q2,TMPQ3,0)
- if TMPQ3=1
- KILL TMPTO
- SET TMPTO(DFN,TMPQ3)=^(0)
- +33 SET PN=PN+2
- SET PSJCHTO=2
- if ($GET(PN)>PSJFULL)
- DO NPAGE
- if PX["^"
- QUIT
- End DoDot:4
- End DoDot:3
- +34 if PX["^"
- QUIT
- +35 IF Q3=1
- IF ($GET(PSJCHTO)'=1)
- if ($GET(PN)>PSJFULL)
- DO NPAGE
- if PX["^"
- QUIT
- Begin DoDot:3
- +36 DO DATUSR($PIECE(AND,"^",5),$PIECE(AND,"^",3),"OTHER PRINT INFO changed")
- +37 ;W !!,"Date: ",$$ENDTC^PSGMI($P(AND,"^",5)) W ?28,"User: ",$$ENNPN^PSGMI($P(AND,"^",3)),!,"OTHER PRINT INFO changed" S PN=$G(PN)+3
- End DoDot:3
- if ($GET(PX)["^")
- QUIT
- +38 IF Q3=1
- IF Q2=3
- IF '$GET(PSJCHTO)
- WRITE !?INDENT1,"From: """""
- SET PSJCHTO=1
- SET PN=$GET(PN)+1
- +39 IF Q3=1
- IF Q2=3
- IF PSJCHTO=2
- IF $DATA(TMPTO(DFN,1))
- WRITE !?INDENT1,"From: "
- SET PSJCHTO=1
- SET PN=$GET(PN)+1
- NEW TMPTOLN
- SET TMPTOLN=0
- FOR
- SET TMPTOLN=$ORDER(TMPTO(DFN,TMPTOLN))
- if 'TMPTOLN!(PX["^")
- QUIT
- WRITE !?INDENT2,TMPTO(DFN,TMPTOLN)
- SET PN=PN+1
- if ($GET(PN)>PSJFULL)
- DO NPAGE
- +40 if (PX["^")
- QUIT
- IF Q3=1
- WRITE !?INDENT1,$SELECT(PSJCHTO'=1:"From: ",PSJCHTO=1:"To: ",1:"")
- SET PSJCHTO=$SELECT(PSJCHTO=1:2,1:1)
- SET PN=PN+1
- if PX["^"
- QUIT
- +41 if PX["^"
- QUIT
- WRITE !?INDENT2,^PS(55,DFN,"IV",+PSGORD,"A",Q,Q2,Q3,0)
- if Q3=1
- KILL TMPTO
- if PSJCHTO=2
- SET TMPTO(DFN,Q3)=^(0)
- SET PN=PN+1
- if ($GET(PN)>PSJFULL)
- DO NPAGE
- if PX["^"
- QUIT
- End DoDot:2
- +42 IF $GET(PN)>PSJFULL
- DO NPAGE
- if (PX["^")
- QUIT
- +43 IF ($GET(PSGORD)["P")
- if ($GET(PN)>PSJFULL)
- DO NPAGE
- if PX["^"
- QUIT
- Begin DoDot:2
- +44 IF ($GET(PSJCHTO)'=1)
- WRITE !,"Date: ",$$ENDTC^PSGMI(+AND)
- WRITE ?28,"User: ",$$ENNPN^PSGMI($PIECE(AND,"^",2)),!,"OTHER PRINT INFO changed"
- SET PN=$GET(PN)+2
- +45 IF '$GET(PSJCHTO)
- NEW FROM
- SET FROM=$PIECE(AND,"^",5)
- SET FROM=$SELECT(FROM]"":FROM,1:"""""")
- WRITE !?INDENT1,"From: ",!?INDENT2,FROM
- SET PSJCHTO=1
- SET PN=$GET(PN)+1
- +46 NEW QB
- SET QB=0
- FOR
- SET QB=$ORDER(^PS(53.1,+PSGORD,"A",Q,QB))
- if 'QB!($GET(PX)["^")
- QUIT
- NEW Q2
- SET Q2=0
- FOR
- SET Q2=$ORDER(^PS(53.1,+PSGORD,"A",Q,QB,Q2))
- if 'Q2!($GET(PX)["^")
- QUIT
- Begin DoDot:3
- +47 IF ($GET(PSJCHTO)<2)
- IF (Q2=1)
- IF (QB=1)
- if ($GET(PN)>PSJFULL)
- DO NPAGE
- WRITE !?INDENT1,"To: "
- SET PN=$GET(PN)+2
- SET PSJCHTO=2
- Begin DoDot:4
- +48 NEW TMPQ2
- SET TMPQ2=0
- FOR
- SET TMPQ2=$ORDER(^PS(53.1,+PSGORD,"A",Q,QB,TMPQ2))
- if 'TMPQ2!(PX["^")
- QUIT
- WRITE !?INDENT2,^PS(53.1,+PSGORD,"A",Q,QB,TMPQ2,0)
- SET PN=$GET(PN)+1
- if ($GET(PN)>PSJFULL)
- DO NPAGE
- End DoDot:4
- WRITE !
- +49 ; W !,"Date: ",$$ENDTC^PSGMI(+AND) W:$S(UD'?4N:1,1:$E(UD,1,2)'=10) ?28,"User: ",$$ENNPN^PSGMI($P(AND,"^",2)),!,"OTHER PRINT INFO changed" S PN=$G(PN)+2
- IF (Q2=1)
- IF (QB=1)
- DO DATUSR($PIECE(AND,"^",5),$PIECE(AND,"^",3),"OTHER PRINT INFO changed")
- +50 IF (Q2=1)
- if ($GET(PN)>PSJFULL)
- DO NPAGE
- WRITE !?INDENT1,$SELECT(QB=1:"From: ",QB=2:"To: ",1:"")
- SET PSJCHTO=$SELECT(QB=2:2,1:1)
- SET PN=$GET(PN)+1
- +51 if ($GET(PX)["^")
- QUIT
- WRITE !?INDENT2,^PS(53.1,+PSGORD,"A",Q,QB,Q2,0)
- SET PN=$GET(PN)+1
- if ($GET(PN)>PSJFULL)
- DO NPAGE
- if PX["^"
- QUIT
- End DoDot:3
- +52 IF ($GET(PN)>PSJFULL)
- DO NPAGE
- End DoDot:2
- End DoDot:1
- +53 QUIT
- +54 ;
- GETPRCOM ; Get provider comments
- +1 NEW PROVLN
- +2 IF $GET(PSGORD)["V"
- SET PROVLN=0
- FOR
- SET PROVLN=$ORDER(^PS(55,DFN,"IV",+PSGORD,5,PROVLN))
- if 'PROVLN!($GET(PX)["^")
- QUIT
- Begin DoDot:1
- +3 IF (PROVLN=1)
- SET DT=$PIECE($GET(^PS(55,DFN,"IV",+PSGORD,2)),"^")
- SET USR=$PIECE($GET(^PS(55,DFN,"IV",+PSGORD,0)),"^",6)
- DO DATUSR(DT,USR,"PROVIDER COMMENTS:")
- SET PSJPRCOM=1
- +4 WRITE !?INDENT2,^PS(55,DFN,"IV",+PSGORD,5,PROVLN,0)
- SET PN=$GET(PN)+1
- IF ($GET(PN)>PSJFULL)
- DO NPAGE
- End DoDot:1
- +5 IF $GET(PSGORD)["U"
- SET PROVLN=0
- FOR
- SET PROVLN=$ORDER(^PS(55,DFN,5,+PSGORD,12,PROVLN))
- if 'PROVLN!($GET(PX)["^")
- QUIT
- Begin DoDot:1
- +6 IF (PROVLN=1)
- SET DT=$PIECE($GET(^PS(55,DFN,5,+PSGORD,0)),"^",16)
- SET USR=$PIECE($GET(^PS(55,DFN,5,+PSGORD,0)),"^",2)
- DO DATUSR(DT,USR,"PROVIDER COMMENTS:")
- SET PSJPRCOM=1
- +7 WRITE !?INDENT2,^PS(55,DFN,5,+PSGORD,12,PROVLN,0)
- SET PN=$GET(PN)+1
- IF ($GET(PN)>PSJFULL)
- DO NPAGE
- End DoDot:1
- +8 IF $GET(PSGORD)["P"
- SET PROVLN=0
- FOR
- SET PROVLN=$ORDER(^PS(53.1,+PSGORD,12,PROVLN))
- if 'PROVLN!($GET(PX)["^")
- QUIT
- Begin DoDot:1
- +9 IF (PROVLN=1)
- SET DT=$PIECE($GET(^PS(53.1,+PSGORD,0)),"^",16)
- SET USR=$PIECE($GET(^PS(53.1,+PSGORD,0)),"^",2)
- DO DATUSR(DT,USR,"PROVIDER COMMENTS:")
- SET PSJPRCOM=1
- +10 WRITE !?INDENT2,^PS(53.1,+PSGORD,12,PROVLN,0)
- SET PN=$GET(PN)+1
- IF ($GET(PN)>PSJFULL)
- DO NPAGE
- End DoDot:1
- +11 if ($GET(PN)>PSJFULL)
- DO NPAGE
- +12 QUIT
- NPAGE ; Pause
- +1 if $GET(PSJPTR)
- QUIT
- +2 IF PN<PSJFULL
- FOR PN=PN:1:PSJFULL-1
- WRITE !
- +3 IF $EXTRACT(IOST)="C"
- READ !!,"Enter '^' to stop, or press RETURN to continue.",PX:DTIME
- Begin DoDot:1
- +4 IF $GET(PX)["^"
- SET DONE=1
- +5 DO FULL^VALM1
- WRITE @IOF
- End DoDot:1
- +6 WRITE !?25,"Instructions History"
- SET PN=1
- +7 NEW DASH
- SET $PIECE(DASH,"-",75)="-"
- WRITE !,DASH
- SET PN=$GET(PN)+1
- +8 QUIT
- +9 ;
- DATUSR(DT,USR,TXT) ;
- +1 IF $GET(PN)>(PSJFULL-5)
- DO NPAGE
- if (PX["^")
- QUIT
- +2 NEW DAT,USER
- +3 SET DAT=$$ENDTC^PSSGMI(DT)
- SET USER=$$ENNPN^PSGMI(USR)
- +4 WRITE !!,"Date: ",DAT,?28,"User: ",USER,!,TXT
- SET PN=$GET(PN)+3
- +5 QUIT
- +6 ;
- CPYPC(DFN,PSGORD,Q) ; Handle Special Instructions copied in from Provider Comments during finishing
- +1 if $ORDER(^PS(55,DFN,5,+PSGORD,9,Q,0))
- QUIT
- +2 NEW PS55ND0
- SET PS55ND0=$GET(^PS(55,DFN,5,+PSGORD,0))
- +3 NEW PRVORD
- SET PRVORD=$PIECE(PS55ND0,"^",25)
- if 'PRVORD
- QUIT
- +4 NEW PRVSI
- SET PRVSI=$$GETSIOPI^PSJBCMA5(DFN,PRVORD,1)
- if 'PRVSI
- QUIT
- +5 IF ($GET(PSJCHTO)=2)
- Begin DoDot:1
- +6 if ($GET(PN)>PSJFULL)
- DO NPAGE
- if ($GET(PX)["^")
- QUIT
- DO DATUSR(+AND,$PIECE(AND,"^",2),"SPECIAL INSTRUCTIONS changed")
- +7 WRITE !?INDENT1,"From:"
- SET PN=$GET(PN)+1
- NEW TMPQ3
- SET TMPQ3=0
- FOR
- SET TMPQ3=$ORDER(^TMP("PSJBCMA5",$JOB,DFN,PRVORD,TMPQ3))
- if 'TMPQ3!(PX["^")
- QUIT
- Begin DoDot:2
- +8 WRITE !?INDENT2,^TMP("PSJBCMA5",$JOB,DFN,PRVORD,TMPQ3)
- SET PN=$GET(PN)+1
- SET PSJCHTO=2
- if TMPQ3=1
- KILL TMPTO
- SET TMPTO(DFN,TMPQ3)=^TMP("PSJBCMA5",$JOB,DFN,PRVORD,TMPQ3)
- End DoDot:2
- +9 SET PSJCHTO=1
- End DoDot:1
- +10 if PX["^"
- QUIT
- if ($GET(PN)>PSJFULL)
- DO NPAGE
- if PX["^"
- QUIT
- +11 if ($GET(PN)>PSJFULL)
- DO NPAGE
- if ($GET(PX)["^")
- QUIT
- DO DATUSR(+AND,$PIECE(AND,"^",2),"SPECIAL INSTRUCTIONS changed")
- +12 if ($GET(PX)["^")
- QUIT
- WRITE !?INDENT1,$SELECT(PSJCHTO=2:"From: ",PSJCHTO=1:"To:",1:"")
- SET PSJCHTO=$SELECT(PSJCHTO=2:1,1:2)
- SET PN=$GET(PN)+1
- +13 NEW TOSI,FOUNDTO
- SET TOSI=Q
- FOR
- if $GET(FOUNDTO)
- QUIT
- SET TOSI=$ORDER(^PS(55,DFN,5,+PSGORD,9,TOSI))
- if 'TOSI
- QUIT
- IF $GET(^PS(55,DFN,5,+PSGORD,9,TOSI,0))["SPECIAL INSTRUCTIONS"
- SET FOUNDTO=TOSI
- +14 IF $GET(FOUNDTO)
- SET TOSI=0
- FOR
- SET TOSI=$ORDER(^PS(55,DFN,5,+PSGORD,9,FOUNDTO,1,TOSI))
- if 'TOSI
- QUIT
- Begin DoDot:1
- +15 WRITE !?INDENT2,^PS(55,DFN,5,+PSGORD,9,FOUNDTO,1,TOSI,0)
- SET PN=$GET(PN)+1
- if TOSI=1
- KILL TMPTO
- if PSJCHTO=2
- SET TMPTO(DFN,TOSI)=^(0)
- End DoDot:1
- +16 if $GET(FOUNDTO)
- QUIT
- +17 SET TOSI=0
- FOR
- SET TOSI=$ORDER(^PS(55,DFN,5,+PSGORD,15,TOSI))
- if 'TOSI
- QUIT
- WRITE !?INDENT2,$GET(^(TOSI,0))
- +18 QUIT