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 Oct 16, 2024@18:07:58 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
