PSJAC ;BIR/CML3 - INPATIENT INFORMATION ;28 Apr 98 / 9:02 AM
;;5.0;INPATIENT MEDICATIONS;**8,10,50,127,181,275,279,331**;16 DEC 97;Build 15
;
; Reference to ^PS(55 is supported by DBIA# 2191.
;
S DFN=PSGP,PSJACPF=1 G CHK
;
ENBOTH ;
S PSJACPF=11 G CHK
;
ENIV ;
N I,J,JJ,ON,PSJRBXX,X,X1,X2,X,Y S PSJACPF=10,PSGP=DFN
;
CHK ;
;Check if 5.0 order conversion should be run for the selected patient.
;I '$P($G(^PS(55,DFN,5.1)),U,11) D CONVERT^PSJUTL1(DFN,$S($E(IOST,1)="C":1,1:0))
;/Commented out in PSJ*5*50. No longer needed
;/F S PSJRBXX=$$OTF^OR3CONV(DFN,$S($E(IOST,1)="C":0,1:1)) Q:+PSJRBXX'<0 D
;/.I +PSJRBXX=-1 W:$E(IOST,1)="C" !,$P(PSJRBXX,"^",2) H 4
;Converting IV order to new OI with POE if not done so when installed PSJ*5*50
D CNIV^PSJUTL1(DFN)
;I $D(^PS(55,DFN,0)),'$P($G(^PS(55,DFN,0)),U,6) D EN^PSOHLUP(DFN)
S VA200=1 D INP^VADPT
I VAIN(4) S:PSJACPF#2 PSJPCAF=1_"^"_VAIN(1),PSJPWD=+VAIN(4),PSJPWDN=$P(VAIN(4),"^",2),PSJPTS=+VAIN(3),PSJPTSP=+VAIN(2),PSJPRB=VAIN(5),PSJPAD=+VAIN(7),PSJPDX=VAIN(9),PSJPTD=$S($D(^PS(55,PSGP,5.1)):$P(^(5.1),"^",4),1:""),PSJPDD="" G CNV
S VAIP("D")="L" D IN5^VADPT G:PSJACPF[0 CNV
S PSJPCAF="",PSJPAD=+VAIP(13,1)
S PSGID=+VAIP(3),X=+VAIP(4)=12!(+VAIP(4)=38)!($G(VADM(6))),PSJPWD=+VAIP(5),PSJPWDN=$P(VAIP(5),"^",2),PSJPRB=$P(VAIP(6),"^",2),PSJPTSP=+VAIP(7),PSJPTS=+VAIP(8),PSJPDX=VAIP(9),PSJPTD="",PSJPDD=PSGID_"^"_$$ENDTC^PSGMI(PSGID) S:X PSJPDD=PSJPDD_"^1"
;
CNV ;
D DEM^VADPT,HTWT(PSGP)
I PSJACPF#2 S PSGP(0)=VADM(1),PSJPSSN=VADM(2),PSJPDOB=+VADM(3),PSJPAGE=VADM(4),PSJPSEX=$S(VADM(5)]"":VADM(5),1:"?^____"),PSJPPID=VA("PID"),PSJPBID=VA("BID")
I PSJACPF#2 D
.I $D(PSJY2K) D Q
..F X="PSJPAD","PSJPDOB","PSJPTD" I @X S $P(@X,"^",2)=$$ENDTC2^PSGMI(+@X)
.F X="PSJPAD","PSJPDOB","PSJPTD" I @X S $P(@X,"^",2)=$$ENDTC^PSGMI(+@X)
;
WP ; ward parameters
G:$D(PSJACNWP) DONE S PSJSYSW0="",PSJSYSW=0 I $G(PSJPWD) S PSJSYSW=+$O(^PS(59.6,"B",PSJPWD,0)) I PSJSYSW S PSJSYSW0=$G(^PS(59.6,PSJSYSW,0))
S PSJSYSL="",X=$P(PSJSYSU,";",3)>1 S PSJSYSL=$S(X=0:$P(PSJSYSW0,"^",12),1:$P(PSJSYSW0,"^",16)) G:$D(PSJACND) DONE
I PSJSYSL D
.S:X X='$P($G(PSJSYSP0),"^",10) S IOP=$S($P($G(PSJSYSP0),"^",13)]"":$P($G(PSJSYSP0),"^",13),$P(PSJSYSW0,"^",19+X)]"":$P(PSJSYSW0,"^",19+X),1:"") I IOP]"" D
..S IOP="`"_IOP K %ZIS S %ZIS="NQ" D ^%ZIS S:'POP $P(PSJSYSL,"^",2,3)=ION_"^"_IO D HOME^%ZIS
;
D CLINIC
;
DONE ;
I PSJACPF<10 K VADM,VAIN,VAIP
K PSJACPF,PSGID,PSGOD,VA200,X
Q
HTWT(DFN) ; Get patient's height and weight from Vitals.
S (PSJPWTD,PSJPHTD)=""
S X="GMRVUTL" X ^%ZOSF("TEST") I S GMRVSTR="HT" D
. D EN6^GMRVUTL S PSJPHT=$P(X,U,8) S:PSJPHT PSJPHT=$J(2.54*PSJPHT,0,2),PSJPHTD="("_$S($D(PSJY2K):$E($$ENDTC2^PSGMI($P(X,U)),1,10),1:$E($$ENDTC^PSGMI($P(X,U)),1,8))_")"
. S GMRVSTR="WT" D EN6^GMRVUTL S PSJPWT=$P(X,U,8) S:PSJPWT PSJPWT=$J(PSJPWT/2.20462262,0,2),PSJPWTD="("_$S($D(PSJY2K):$E($$ENDTC2^PSGMI($P(X,U)),1,10),1:$E($$ENDTC^PSGMI($P(X,U)),1,8))_")"
F X="PSJPWT","PSJPHT" S:'$G(@X) @X="______"
F X="PSJPWTD","PSJPHTD" S:$G(@X)="" @X="(________)"
Q
PSJAC2(PSJY2K) ;
D PSJAC Q
Q
ACTCLIN(PSGP,PSGORD) ; Don't allow active clinic orders to be copied. If Pending order, allow CLINIC^PSJOE to reject based on order status.
N CLIN,CLNODE S CLIN=0
I $G(PSGORD)["P"!($G(PSGORD)=+$G(PSGORD)) S CLIN=0
I $G(PSGORD)["U" S CLNODE=$G(^PS(55,PSGP,5,+PSGORD,8)) I CLNODE&($P(CLNODE,"^",2)) S CLIN=1
I $G(PSGORD)["V" S CLNODE=$G(^PS(55,PSGP,"IV",+PSGORD,"DSS")) I CLNODE&($P(CLNODE,"^",2)) S CLIN=1
I $G(CLIN) W !!,"You cannot copy this CLINIC Order." D PAUSE^VALM1 Q 1
Q 0
;
CLINIC ; clinic parameters
N CL,CLIEN,CLNAM S CL=0 F S CL=$O(^PS(53.46,CL)) Q:'CL S CLIEN=$G(^(CL,0)) I CLIEN S PSJSYSW0("CLINIC",+CLIEN,0)=CLIEN I $D(^PS(53.46,CL,1)) S PSJSYSW0("CLINIC",+CLIEN,1)=^(1)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJAC 3824 printed Sep 23, 2025@19:42:11 Page 2
PSJAC ;BIR/CML3 - INPATIENT INFORMATION ;28 Apr 98 / 9:02 AM
+1 ;;5.0;INPATIENT MEDICATIONS;**8,10,50,127,181,275,279,331**;16 DEC 97;Build 15
+2 ;
+3 ; Reference to ^PS(55 is supported by DBIA# 2191.
+4 ;
+5 SET DFN=PSGP
SET PSJACPF=1
GOTO CHK
+6 ;
ENBOTH ;
+1 SET PSJACPF=11
GOTO CHK
+2 ;
ENIV ;
+1 NEW I,J,JJ,ON,PSJRBXX,X,X1,X2,X,Y
SET PSJACPF=10
SET PSGP=DFN
+2 ;
CHK ;
+1 ;Check if 5.0 order conversion should be run for the selected patient.
+2 ;I '$P($G(^PS(55,DFN,5.1)),U,11) D CONVERT^PSJUTL1(DFN,$S($E(IOST,1)="C":1,1:0))
+3 ;/Commented out in PSJ*5*50. No longer needed
+4 ;/F S PSJRBXX=$$OTF^OR3CONV(DFN,$S($E(IOST,1)="C":0,1:1)) Q:+PSJRBXX'<0 D
+5 ;/.I +PSJRBXX=-1 W:$E(IOST,1)="C" !,$P(PSJRBXX,"^",2) H 4
+6 ;Converting IV order to new OI with POE if not done so when installed PSJ*5*50
+7 DO CNIV^PSJUTL1(DFN)
+8 ;I $D(^PS(55,DFN,0)),'$P($G(^PS(55,DFN,0)),U,6) D EN^PSOHLUP(DFN)
+9 SET VA200=1
DO INP^VADPT
+10 IF VAIN(4)
if PSJACPF#2
SET PSJPCAF=1_"^"_VAIN(1)
SET PSJPWD=+VAIN(4)
SET PSJPWDN=$PIECE(VAIN(4),"^",2)
SET PSJPTS=+VAIN(3)
SET PSJPTSP=+VAIN(2)
SET PSJPRB=VAIN(5)
SET PSJPAD=+VAIN(7)
SET PSJPDX=VAIN(9)
SET PSJPTD=$SELECT($DATA(^PS(55,PSGP,5.1)):$PIECE(^(5.1),"^",4),1:"")
SET PSJPDD=""
GOTO CNV
+11 SET VAIP("D")="L"
DO IN5^VADPT
if PSJACPF[0
GOTO CNV
+12 SET PSJPCAF=""
SET PSJPAD=+VAIP(13,1)
+13 SET PSGID=+VAIP(3)
SET X=+VAIP(4)=12!(+VAIP(4)=38)!($GET(VADM(6)))
SET PSJPWD=+VAIP(5)
SET PSJPWDN=$PIECE(VAIP(5),"^",2)
SET PSJPRB=$PIECE(VAIP(6),"^",2)
SET PSJPTSP=+VAIP(7)
SET PSJPTS=+VAIP(8)
SET PSJPDX=VAIP(9)
SET PSJPTD=""
SET PSJPDD=PSGID_"^"_$$ENDTC^PSGMI(PSGID)
if X
SET PSJPDD=PSJPDD_"^1"
+14 ;
CNV ;
+1 DO DEM^VADPT
DO HTWT(PSGP)
+2 IF PSJACPF#2
SET PSGP(0)=VADM(1)
SET PSJPSSN=VADM(2)
SET PSJPDOB=+VADM(3)
SET PSJPAGE=VADM(4)
SET PSJPSEX=$SELECT(VADM(5)]"":VADM(5),1:"?^____")
SET PSJPPID=VA("PID")
SET PSJPBID=VA("BID")
+3 IF PSJACPF#2
Begin DoDot:1
+4 IF $DATA(PSJY2K)
Begin DoDot:2
+5 FOR X="PSJPAD","PSJPDOB","PSJPTD"
IF @X
SET $PIECE(@X,"^",2)=$$ENDTC2^PSGMI(+@X)
End DoDot:2
QUIT
+6 FOR X="PSJPAD","PSJPDOB","PSJPTD"
IF @X
SET $PIECE(@X,"^",2)=$$ENDTC^PSGMI(+@X)
End DoDot:1
+7 ;
WP ; ward parameters
+1 if $DATA(PSJACNWP)
GOTO DONE
SET PSJSYSW0=""
SET PSJSYSW=0
IF $GET(PSJPWD)
SET PSJSYSW=+$ORDER(^PS(59.6,"B",PSJPWD,0))
IF PSJSYSW
SET PSJSYSW0=$GET(^PS(59.6,PSJSYSW,0))
+2 SET PSJSYSL=""
SET X=$PIECE(PSJSYSU,";",3)>1
SET PSJSYSL=$SELECT(X=0:$PIECE(PSJSYSW0,"^",12),1:$PIECE(PSJSYSW0,"^",16))
if $DATA(PSJACND)
GOTO DONE
+3 IF PSJSYSL
Begin DoDot:1
+4 if X
SET X='$PIECE($GET(PSJSYSP0),"^",10)
SET IOP=$SELECT($PIECE($GET(PSJSYSP0),"^",13)]"":$PIECE($GET(PSJSYSP0),"^",13),$PIECE(PSJSYSW0,"^",19+X)]"":$PIECE(PSJSYSW0,"^",19+X),1:"")
IF IOP]""
Begin DoDot:2
+5 SET IOP="`"_IOP
KILL %ZIS
SET %ZIS="NQ"
DO ^%ZIS
if 'POP
SET $PIECE(PSJSYSL,"^",2,3)=ION_"^"_IO
DO HOME^%ZIS
End DoDot:2
End DoDot:1
+6 ;
+7 DO CLINIC
+8 ;
DONE ;
+1 IF PSJACPF<10
KILL VADM,VAIN,VAIP
+2 KILL PSJACPF,PSGID,PSGOD,VA200,X
+3 QUIT
HTWT(DFN) ; Get patient's height and weight from Vitals.
+1 SET (PSJPWTD,PSJPHTD)=""
+2 SET X="GMRVUTL"
XECUTE ^%ZOSF("TEST")
IF $TEST
SET GMRVSTR="HT"
Begin DoDot:1
+3 DO EN6^GMRVUTL
SET PSJPHT=$PIECE(X,U,8)
if PSJPHT
SET PSJPHT=$JUSTIFY(2.54*PSJPHT,0,2)
SET PSJPHTD="("_$SELECT($DATA(PSJY2K):$EXTRACT($$ENDTC2^PSGMI($PIECE(X,U)),1,10),1:$EXTRACT($$ENDTC^PSGMI($PIECE(X,U)),1,8))_")"
+4 SET GMRVSTR="WT"
DO EN6^GMRVUTL
SET PSJPWT=$PIECE(X,U,8)
if PSJPWT
SET PSJPWT=$JUSTIFY(PSJPWT/2.20462262,0,2)
SET PSJPWTD="("_$SELECT($DATA(PSJY2K):$EXTRACT($$ENDTC2^PSGMI($PIECE(X,U)),1,10),1:$EXTRACT($$ENDTC^PSGMI($PIECE(X,U)),1,8))_")"
End DoDot:1
+5 FOR X="PSJPWT","PSJPHT"
if '$GET(@X)
SET @X="______"
+6 FOR X="PSJPWTD","PSJPHTD"
if $GET(@X)=""
SET @X="(________)"
+7 QUIT
PSJAC2(PSJY2K) ;
+1 DO PSJAC
QUIT
+2 QUIT
ACTCLIN(PSGP,PSGORD) ; Don't allow active clinic orders to be copied. If Pending order, allow CLINIC^PSJOE to reject based on order status.
+1 NEW CLIN,CLNODE
SET CLIN=0
+2 IF $GET(PSGORD)["P"!($GET(PSGORD)=+$GET(PSGORD))
SET CLIN=0
+3 IF $GET(PSGORD)["U"
SET CLNODE=$GET(^PS(55,PSGP,5,+PSGORD,8))
IF CLNODE&($PIECE(CLNODE,"^",2))
SET CLIN=1
+4 IF $GET(PSGORD)["V"
SET CLNODE=$GET(^PS(55,PSGP,"IV",+PSGORD,"DSS"))
IF CLNODE&($PIECE(CLNODE,"^",2))
SET CLIN=1
+5 IF $GET(CLIN)
WRITE !!,"You cannot copy this CLINIC Order."
DO PAUSE^VALM1
QUIT 1
+6 QUIT 0
+7 ;
CLINIC ; clinic parameters
+1 NEW CL,CLIEN,CLNAM
SET CL=0
FOR
SET CL=$ORDER(^PS(53.46,CL))
if 'CL
QUIT
SET CLIEN=$GET(^(CL,0))
IF CLIEN
SET PSJSYSW0("CLINIC",+CLIEN,0)=CLIEN
IF $DATA(^PS(53.46,CL,1))
SET PSJSYSW0("CLINIC",+CLIEN,1)=^(1)
+2 QUIT
