- 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 Jan 18, 2025@03:07:18 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