PSJMISC ;BIR/MV - MISC. SUB-ROUTINES ;03 Aug 98 / 8:42 AM
;;5.0;INPATIENT MEDICATIONS;**181,256**;16 DEC 97;Build 34
;
; Reference to ^PS(50.7 is supported by DBIA# 2180.
; Reference to ^PS(52.6 is supported by DBIA# 1231.
; Reference to ^PS(52.7 is supported by DBIA# 2173.
; Reference to ^PS(55 is supported by DBIA# 2191.
; Reference to ^PSDRUG is supported by DBIA# 2192.
;
GCN(PSJDD) ;Return GCNSEQNO for a dispense drug
;PSJDD - IEN (file #50)
NEW PSJDDND,X
I '+$G(PSJDD) Q ""
S PSJDDND=$G(^PSDRUG(+PSJDD,"ND"))
I PSJDDND="" Q ""
S X=$$PROD0^PSNAPIS($P(PSJDDND,U),$P(PSJDDND,U,3))
Q $P(X,U,7)
GTVUID(PSJDD) ;Return the VUID for a dispense drug
;PSJDD - IEN (file #50)
NEW PSJND,PSJVUID,DIC
I '+$G(PSJDD) Q ""
S PSJVUID=""
S PSJND=$P($G(^PSDRUG(+PSJDD,"ND")),U,3)
I +PSJND S PSJVUID=$$GETVUID^XTID(50.68,,PSJND_",")
Q PSJVUID
VAGEN(PSJDD) ;Return the VA GENERIC name
;PSJDD - IEN (file #50)
NEW PSJIEN,PSJVAGEN
I '+$G(PSJDD) Q ""
S PSJIEN=+$G(^PSDRUG(PSJDD,"ND"))
D ZERO^PSN50P6(PSJIEN,,,,"PSJVAGEN")
S PSJVAGEN=$G(^TMP($J,"PSJVAGEN",PSJIEN,.01))
K ^TMP($J,"PSJVAGEN")
Q PSJVAGEN
;
GENVUID(PSJVUID) ;Return the VA GENERIC name
;PSJVUID - #50.68
;PSJRDIID - Array returning from ^XTID call
;PSJNDF - #50.68 ien
;GETIREF^XTID - will not return the .01 name if DIC is defined.
I '+$G(PSJVUID) Q ""
NEW PSJNDF,PSJVAGEN,DIC
K PSJRDIID
S PSJVAGEN=""
D GETIREF^XTID("50.68",".01",PSJVUID,"PSJRDIID")
S PSJNDF=$O(PSJRDIID(50.68,.01,""))
K PSJRDIID
I +PSJNDF D
. D DATA^PSN50P68(+PSJNDF,,"PSJNDF")
. S PSJVAGEN=$P($G(^TMP($J,"PSJNDF",+PSJNDF,.05)),U,2)
K ^TMP($J,"PSJNDF")
Q PSJVAGEN
;
CLASS(PSJDD) ;Return the VA CLASS
Q:'+$G(PSJDD) ""
NEW PSJCLASS
S PSJCLASS=$P($G(^PSDRUG(+PSJDD,0)),U,2)
Q PSJCLASS
;
PREMIX(X) ;Check if the solution is flag as a Pre-mix
;X - ien from 52.7
;Return 0 if not flag as premix.
I '+$G(X) Q 0
Q +$P($G(^PS(52.7,+X,0)),U,14)
;
IVDDRG(PSIVAS,PSJIEN) ;Return corresponding dispense drug IEN for ad/sol
;PSJIEN - ien from 52.6 or 52.7
;PSIVAS - "AD" or "SOL"
NEW DDRUG
I PSIVAS="AD" S DDRUG=$P($G(^PS(52.6,+PSJIEN,0)),U,2)
I PSIVAS="SOL" S DDRUG=$P($G(^PS(52.7,+PSJIEN,0)),U,2)
Q DDRUG
;
WRITE(X,DIWL,DIWR) ;Start a new line before writing
NEW DN
I '$G(DIWL) S DIWL=1
I '$G(DIWR) S DIWR=75
K ^UTILITY($J,"W") D ^DIWP D ^DIWW
Q
;
MYWRITE(X,DIWL,DIWR) ;Continue writing on the same line
NEW DN,PSJCNT
I '$G(DIWL) S DIWL=1
I '$G(DIWR) S DIWR=75
K ^UTILITY($J,"W") D ^DIWP
F PSJCNT=0:0 S PSJCNT=$O(^UTILITY($J,"W",DIWL,PSJCNT)) Q:'PSJCNT W:PSJCNT'=1 ! W ?DIWL,^UTILITY($J,"W",DIWL,PSJCNT,0)
Q
;
COMPARE(DRG,TMPDRG,PSJNPRMX) ;
;PSJNPRMX is set to consider non-premix solution.
;Compare the DRG array if it has changed
;Returning 1 will cause OC to be performed due to add/sol changes or new OE
I '$D(DRG) Q 0
I $D(DRG),('$D(TMPDRG)) Q 1
NEW PSJDIFF,PSJX,X
S PSJDIFF=0
F X=0:0 S X=$O(DRG("AD",X)) Q:'X!PSJDIFF S PSJX=DRG("AD",X) D
. I DRG("AD",X)'=$G(TMPDRG("AD",X)) S PSJDIFF=1 Q
I PSJDIFF Q 1
F X=0:0 S X=$O(DRG("SOL",X)) Q:'X!PSJDIFF S PSJX=DRG("SOL",X) D
. I '+$G(PSJNPRMX),'$$PREMIX(+PSJX) Q
. I DRG("SOL",X)'=$G(TMPDRG("SOL",X)) S PSJDIFF=1 Q
I PSJDIFF Q 1
F X=0:0 S X=$O(TMPDRG("AD",X)) Q:'X!PSJDIFF S PSJX=TMPDRG("AD",X) D
. I TMPDRG("AD",X)'=$G(DRG("AD",X)) S PSJDIFF=1 Q
I PSJDIFF Q 1
F X=0:0 S X=$O(TMPDRG("SOL",X)) Q:'X!PSJDIFF S PSJX=TMPDRG("SOL",X) D
. I '+$G(PSJNPRMX),'$$PREMIX(+PSJX) Q
. I TMPDRG("SOL",X)'=$G(DRG("SOL",X)) S PSJDIFF=1 Q
Q PSJDIFF
DN(X) ;
;Return the drug name from file 50
Q $P($G(^PSDRUG(+X,0)),U)
OI(X) ;
;Return the Orderable name from file 50.7
NEW PSJX
S PSJX=$P($G(^PS(50.7,+X,0)),U)
Q $S(PSJX="":"Invalid Orderable Item",1:PSJX)
LINE(PSJLINE,PSJLEN) ;Display a line
;PSJLINE - type of line (ex: '-', '=")
;PSJLEN - the length of line
S X="",$P(X,PSJLINE,PSJLEN)=""
W X
Q
DD53P45() ;Return the zero node of the first dispense drug found in 53.45
;Calling routine needs to clean up PSJALLGY array.
NEW PSJDD,PSJDD1,PSJDD0,X,PSJX,PSGDT,%
D NOW^%DTC S PSGDT=%
S PSJDD="",PSJDD1=""
I '+$G(PSJSYSP) Q ""
F X=0:0 S X=$O(^PS(53.45,+PSJSYSP,2,X)) Q:'+X D
. S PSJDD0=$G(^PS(53.45,PSJSYSP,2,X,0))
. S PSJX=$P(PSJDD0,U,3) I PSJX]"",(PSJX'>$G(PSGDT)) S PSJDD0="" Q
. S PSJDD=+PSJDD0
. S PSJX=$S('$D(^PSDRUG(+PSJDD,0)):1,$P($G(^(2)),U,3)'["U":1,$G(^("I"))="":0,1:^("I")'>$G(PSGDT))
. I PSJX S PSJDD0="",PSJDD="" Q
. S PSJALLGY(PSJDD)=""
. S:PSJDD1="" PSJDD1=PSJDD0
Q $G(PSJDD1)
RETQUIT() ;
;Return 1 If enter "^"
NEW DIR,DIROUT,DTOUT,DUOUT,PSJQUIT
S PSJQUIT=0
S DIR(0)="FO^1:1",DIR("A")="Press RETURN to continue or '^' to exit"
S DIR("?")="Enter '^' to quit or any keys to continue"
D ^DIR
I $S($D(DIROUT):1,$D(DUOUT):1,$D(DTOUT):1,1:0) S PSJQUIT=1
Q PSJQUIT
PAUSE(PSJFIRST,PSJLAST) ;
;PSJFIRST - Print a blank line before the pause prompt
;PSJLAST - Print a blank line after the pause prompt
K DIR W:+$G(PSJFIRST) ! S DIR(0)="EA",DIR("A")="Press Return to continue...",DIR("?")="Press Return to continue..." D ^DIR W:+$G(PSJLAST) !
Q
PAUSE1() ;Allow "^"
;Return 0 if X=""
;Return 1 if X="^"
;Return 2 if Not null or "^"
NEW DIR,DIRUT,DUOUT,X
K DIR S DIR("A")="Press RETURN to continue or ""^"" to display the next Monograph or ""^^"" to Exit"
S DIR("?")="Enter ""^"" to go to next Monograph, ""^^"" to exit the Monograph display."
S DIR(0)="FOU^^K:(X'="""")!(X'[""^"") X"
D ^DIR
I X="" Q 0
I X="^" Q 1
Q 2
ONCALL(PSJSCH,PSJSTYPE) ;
; PSJSCH = Admin Schedule
; PSJSTYPE = schedule type (optional)
; Returns 0 = Not an "ON CALL" schedule.
; 1 = For schedule ="ON CALL" or schedule type = "OC".
Q:$G(PSJSTYPE)="OC" 1
Q:$G(PSJSCH)="" 0
I PSJSCH="ON CALL"!(PSJSCH="ONCALL")!(PSJSCH="ON-CALL") Q 1
Q 0
TMPDRG(DFN,ON,TMPDRG) ;Set TMPDRG array from the order in 55
;ON - IV order #
NEW DRGT,FIL,Y,ND,DRG,DRGI
Q:'+$G(ON)
F DRGT="AD","SOL" S FIL=$S(DRGT="AD":52.6,1:52.7) F Y=0:0 S Y=$O(^PS(55,DFN,"IV",+ON,DRGT,Y)) Q:'Y D
.; naked ref below refers to line above
.S DRG=$G(^(Y,0)),ND=$G(^PS(FIL,+DRG,0)),(DRGI,TMPDRG(DRGT,0))=$G(TMPDRG(DRGT,0))+1
.S TMPDRG(DRGT,+DRGI)=+DRG_U_$P(ND,U)_U_$P(DRG,U,2)_U_$P(DRG,U,3)_U_$P(ND,U,13)_U_$P(ND,U,11)
Q
TMPDRG1(DFN,ON,TMPDRG) ;Set TMPDRG array from the order in 53.1
;ON - IV order #
NEW DRGT,FIL,Y,ND,DRG,DRGI
Q:'+$G(ON)
I $P(^PS(53.1,+ON,0),U,15)'=DFN Q
F DRGT="AD","SOL" S FIL=$S(DRGT="AD":52.6,1:52.7) F Y=0:0 S Y=$O(^PS(53.1,+ON,DRGT,Y)) Q:'Y D
.; naked ref below refers to line above
.S DRG=$G(^(Y,0)),ND=$G(^PS(FIL,+DRG,0)),(DRGI,TMPDRG(DRGT,0))=$G(TMPDRG(DRGT,0))+1
.S TMPDRG(DRGT,+DRGI)=+DRG_U_$P(ND,U)_U_$P(DRG,U,2)_U_$P(DRG,U,3)_U_$P(ND,U,13)_U_$P(ND,U,11)
Q
INFRATE(DFN,ON,PSJIR,PSJDTYP) ;Check if the infusion rate has changed
;ON - ON_P/V
;PSJIR - infusion rate
;PSJDTYP - IV type. Only check infusion rate on continuous IV type
NEW X,PSJONIR
I '$D(PSJDTYP)!(+$G(PSJDTYP)=1) Q 0
I '+$G(ON) Q 0
I $G(PSJIR)="" Q 0
I ON["V" S X=$G(^PS(55,DFN,"IV",+ON,0)) S PSJONIR=$P(X,U,8)
I ON["P" S X=$G(^PS(53.1,+ON,8)) S PSJONIR=$P(X,U,5)
I PSJONIR="" Q 0
I PSJIR'=PSJONIR Q 1
Q 0
ADDD(PSJOI) ;Return the best dispense drug IEN for giving OI from the additive file
;PSJOI - 50.7 ien
;Output - 50 ien^52.6 ien or null
;PSJLIST(S1,S2) - sort by Use for IV fluid first
; S1=1 for active DD & has GCN; 2=active DD; 3=inactive DD;
; 4=active DD & has GCN; 5=active DD;6=inactive DD; S2 - DDIEN
Q:'+$G(PSJOI)
NEW PSJOK,PSIVIEN,PSIVIEN0,PSJINACT,PSJDDX,PSJACTDD,PSJGCN,PSJLIST,PSJFLUID
S PSJOK=0
F PSIVIEN=0:0 S PSIVIEN=$O(^PS(52.6,"AOI",PSJOI,PSIVIEN)) Q:'PSIVIEN Q:PSJOK D
. S PSJACTDD=1,PSJGCN=0,PSJFLUID=0
. S PSJINACT=$G(^PS(52.6,PSIVIEN,"I"))
. I PSJINACT]"",(PSJINACT'>DT) Q
. S PSIVIEN0=$G(^PS(52.6,PSIVIEN,0))
. I PSIVIEN0]"" D
.. S PSJDD=+$P(PSIVIEN0,U,2)
.. S PSJINACT=$G(^PSDRUG(PSJDD,"I"))
.. I PSJINACT]"",(PSJINACT'>DT) S PSJACTDD=0
.. I $P(PSIVIEN0,U,13) S PSJFLUID=1
.. I +$$GCN^PSJMISC(PSJDD) S PSJGCN=1
. I PSJFLUID D
.. I PSJACTDD,PSJGCN S PSJLIST(1,PSJDD)=PSIVIEN S PSJOK=1 Q
.. I PSJACTDD S PSJLIST(2,PSJDD)=PSIVIEN Q
.. I PSJDD S PSJLIST(3,PSJDD)=PSIVIEN
. I 'PSJFLUID D
.. I PSJACTDD,PSJGCN S PSJLIST(4,PSJDD)=PSIVIEN Q
.. I PSJACTDD S PSJLIST(5,PSJDD)=PSIVIEN Q
.. I PSJDD S PSJLIST(6,PSJDD)=PSIVIEN
I '$D(PSJLIST) Q ""
S (PSJDD,PSSIEN)=0,PSJDDX=$O(PSJLIST(0))
I +PSJDDX S PSJDD=$O(PSJLIST(PSJDDX,0)),PSIVIEN=PSJLIST(PSJDDX,PSJDD) Q PSJDD_U_PSIVIEN
Q ""
SOLDD(PSJOI,PSJVOL) ;Return the best dispense drug IEN for giving OI from the solution file
;PSJOI - 50.7 ien
;Output - 50 ien^52.7 ien or null
;PSJLIST(s1,s2) - Set the list for the drugs in specific criteria for a best drug to use for dosing check
; sort by Use for IV fluid first
; IV fluid: s1: 1 - premix, active dd & matche; 2 - premix & active dd; 3 - premix ; 4 - inactive dd
; Not IV fluid: 5 - premix, active dd & matche; 6 - premix & active dd; 7 - premix ; 8 - inactive dd; s2 - Sol ien
;note - Only select sol entries with the exact volume.
Q:'+$G(PSJOI)
NEW PSJOK,PSIVIEN,PSJINACT,PSJDDX,PSJACTDD,PSJGCN,PSJLIST,PSJPREMX,PSJSOL,PSJFLUID
S PSJOK=0,PSJFLUID=0
F PSIVIEN=0:0 S PSIVIEN=$O(^PS(52.7,"AOI",PSJOI,PSIVIEN)) Q:'PSIVIEN Q:PSJOK D
. S PSJACTDD=1,PSJGCN=0,PSJPREMX=0
. S PSJINACT=$G(^PS(52.7,PSIVIEN,"I"))
. I PSJINACT]"",(PSJINACT'>DT) Q
. ;Q if volume isn't matched
. S PSJSOL=$G(^PS(52.7,PSIVIEN,0))
. I +$P(PSJSOL,U,3)'=+PSJVOL Q
. S PSJDD=+$P($G(^PS(52.7,+PSIVIEN,0)),U,2)
. S PSJINACT=$G(^PSDRUG(PSJDD,"I"))
. I PSJINACT]"",(PSJINACT'>DT) S PSJACTDD=0
. I +$$GCN^PSJMISC(PSJDD) S PSJGCN=1
. I +$$PREMIX^PSJMISC(PSJDD) S PSJPREMX=1
. I +$P(PSJSOL,U,13) S PSJFLUID=1
. I PSJFLUID D
.. I PSJPREMX,PSJACTDD,PSJGCN S PSJLIST(1,PSJDD)=PSIVIEN S PSJOK=1 Q
.. I PSJPREMX,PSJACTDD S PSJLIST(2,PSJDD)=PSIVIEN Q
.. I PSJPREMX S PSJLIST(3,PSJDD)=PSIVIEN Q
.. I PSJDD S PSJLIST(4,PSJDD)=PSIVIEN
. I 'PSJFLUID D
.. I PSJPREMX,PSJACTDD,PSJGCN S PSJLIST(5,PSJDD)=PSIVIEN Q
.. I PSJPREMX,PSJACTDD S PSJLIST(6,PSJDD)=PSIVIEN Q
.. I PSJPREMX S PSJLIST(7,PSJDD)=PSIVIEN Q
.. I PSJDD S PSJLIST(8,PSJDD)=PSIVIEN
I '$D(PSJLIST) Q ""
S (PSJDD,PSSIEN)=0,PSJDDX=$O(PSJLIST(0))
I +PSJDDX S PSJDD=$O(PSJLIST(PSJDDX,0)),PSIVIEN=PSJLIST(PSJDDX,PSJDD) Q PSJDD_U_PSIVIEN
Q ""
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJMISC 10480 printed Dec 13, 2024@02:07:41 Page 2
PSJMISC ;BIR/MV - MISC. SUB-ROUTINES ;03 Aug 98 / 8:42 AM
+1 ;;5.0;INPATIENT MEDICATIONS;**181,256**;16 DEC 97;Build 34
+2 ;
+3 ; Reference to ^PS(50.7 is supported by DBIA# 2180.
+4 ; Reference to ^PS(52.6 is supported by DBIA# 1231.
+5 ; Reference to ^PS(52.7 is supported by DBIA# 2173.
+6 ; Reference to ^PS(55 is supported by DBIA# 2191.
+7 ; Reference to ^PSDRUG is supported by DBIA# 2192.
+8 ;
GCN(PSJDD) ;Return GCNSEQNO for a dispense drug
+1 ;PSJDD - IEN (file #50)
+2 NEW PSJDDND,X
+3 IF '+$GET(PSJDD)
QUIT ""
+4 SET PSJDDND=$GET(^PSDRUG(+PSJDD,"ND"))
+5 IF PSJDDND=""
QUIT ""
+6 SET X=$$PROD0^PSNAPIS($PIECE(PSJDDND,U),$PIECE(PSJDDND,U,3))
+7 QUIT $PIECE(X,U,7)
GTVUID(PSJDD) ;Return the VUID for a dispense drug
+1 ;PSJDD - IEN (file #50)
+2 NEW PSJND,PSJVUID,DIC
+3 IF '+$GET(PSJDD)
QUIT ""
+4 SET PSJVUID=""
+5 SET PSJND=$PIECE($GET(^PSDRUG(+PSJDD,"ND")),U,3)
+6 IF +PSJND
SET PSJVUID=$$GETVUID^XTID(50.68,,PSJND_",")
+7 QUIT PSJVUID
VAGEN(PSJDD) ;Return the VA GENERIC name
+1 ;PSJDD - IEN (file #50)
+2 NEW PSJIEN,PSJVAGEN
+3 IF '+$GET(PSJDD)
QUIT ""
+4 SET PSJIEN=+$GET(^PSDRUG(PSJDD,"ND"))
+5 DO ZERO^PSN50P6(PSJIEN,,,,"PSJVAGEN")
+6 SET PSJVAGEN=$GET(^TMP($JOB,"PSJVAGEN",PSJIEN,.01))
+7 KILL ^TMP($JOB,"PSJVAGEN")
+8 QUIT PSJVAGEN
+9 ;
GENVUID(PSJVUID) ;Return the VA GENERIC name
+1 ;PSJVUID - #50.68
+2 ;PSJRDIID - Array returning from ^XTID call
+3 ;PSJNDF - #50.68 ien
+4 ;GETIREF^XTID - will not return the .01 name if DIC is defined.
+5 IF '+$GET(PSJVUID)
QUIT ""
+6 NEW PSJNDF,PSJVAGEN,DIC
+7 KILL PSJRDIID
+8 SET PSJVAGEN=""
+9 DO GETIREF^XTID("50.68",".01",PSJVUID,"PSJRDIID")
+10 SET PSJNDF=$ORDER(PSJRDIID(50.68,.01,""))
+11 KILL PSJRDIID
+12 IF +PSJNDF
Begin DoDot:1
+13 DO DATA^PSN50P68(+PSJNDF,,"PSJNDF")
+14 SET PSJVAGEN=$PIECE($GET(^TMP($JOB,"PSJNDF",+PSJNDF,.05)),U,2)
End DoDot:1
+15 KILL ^TMP($JOB,"PSJNDF")
+16 QUIT PSJVAGEN
+17 ;
CLASS(PSJDD) ;Return the VA CLASS
+1 if '+$GET(PSJDD)
QUIT ""
+2 NEW PSJCLASS
+3 SET PSJCLASS=$PIECE($GET(^PSDRUG(+PSJDD,0)),U,2)
+4 QUIT PSJCLASS
+5 ;
PREMIX(X) ;Check if the solution is flag as a Pre-mix
+1 ;X - ien from 52.7
+2 ;Return 0 if not flag as premix.
+3 IF '+$GET(X)
QUIT 0
+4 QUIT +$PIECE($GET(^PS(52.7,+X,0)),U,14)
+5 ;
IVDDRG(PSIVAS,PSJIEN) ;Return corresponding dispense drug IEN for ad/sol
+1 ;PSJIEN - ien from 52.6 or 52.7
+2 ;PSIVAS - "AD" or "SOL"
+3 NEW DDRUG
+4 IF PSIVAS="AD"
SET DDRUG=$PIECE($GET(^PS(52.6,+PSJIEN,0)),U,2)
+5 IF PSIVAS="SOL"
SET DDRUG=$PIECE($GET(^PS(52.7,+PSJIEN,0)),U,2)
+6 QUIT DDRUG
+7 ;
WRITE(X,DIWL,DIWR) ;Start a new line before writing
+1 NEW DN
+2 IF '$GET(DIWL)
SET DIWL=1
+3 IF '$GET(DIWR)
SET DIWR=75
+4 KILL ^UTILITY($JOB,"W")
DO ^DIWP
DO ^DIWW
+5 QUIT
+6 ;
MYWRITE(X,DIWL,DIWR) ;Continue writing on the same line
+1 NEW DN,PSJCNT
+2 IF '$GET(DIWL)
SET DIWL=1
+3 IF '$GET(DIWR)
SET DIWR=75
+4 KILL ^UTILITY($JOB,"W")
DO ^DIWP
+5 FOR PSJCNT=0:0
SET PSJCNT=$ORDER(^UTILITY($JOB,"W",DIWL,PSJCNT))
if 'PSJCNT
QUIT
if PSJCNT'=1
WRITE !
WRITE ?DIWL,^UTILITY($JOB,"W",DIWL,PSJCNT,0)
+6 QUIT
+7 ;
COMPARE(DRG,TMPDRG,PSJNPRMX) ;
+1 ;PSJNPRMX is set to consider non-premix solution.
+2 ;Compare the DRG array if it has changed
+3 ;Returning 1 will cause OC to be performed due to add/sol changes or new OE
+4 IF '$DATA(DRG)
QUIT 0
+5 IF $DATA(DRG)
IF ('$DATA(TMPDRG))
QUIT 1
+6 NEW PSJDIFF,PSJX,X
+7 SET PSJDIFF=0
+8 FOR X=0:0
SET X=$ORDER(DRG("AD",X))
if 'X!PSJDIFF
QUIT
SET PSJX=DRG("AD",X)
Begin DoDot:1
+9 IF DRG("AD",X)'=$GET(TMPDRG("AD",X))
SET PSJDIFF=1
QUIT
End DoDot:1
+10 IF PSJDIFF
QUIT 1
+11 FOR X=0:0
SET X=$ORDER(DRG("SOL",X))
if 'X!PSJDIFF
QUIT
SET PSJX=DRG("SOL",X)
Begin DoDot:1
+12 IF '+$GET(PSJNPRMX)
IF '$$PREMIX(+PSJX)
QUIT
+13 IF DRG("SOL",X)'=$GET(TMPDRG("SOL",X))
SET PSJDIFF=1
QUIT
End DoDot:1
+14 IF PSJDIFF
QUIT 1
+15 FOR X=0:0
SET X=$ORDER(TMPDRG("AD",X))
if 'X!PSJDIFF
QUIT
SET PSJX=TMPDRG("AD",X)
Begin DoDot:1
+16 IF TMPDRG("AD",X)'=$GET(DRG("AD",X))
SET PSJDIFF=1
QUIT
End DoDot:1
+17 IF PSJDIFF
QUIT 1
+18 FOR X=0:0
SET X=$ORDER(TMPDRG("SOL",X))
if 'X!PSJDIFF
QUIT
SET PSJX=TMPDRG("SOL",X)
Begin DoDot:1
+19 IF '+$GET(PSJNPRMX)
IF '$$PREMIX(+PSJX)
QUIT
+20 IF TMPDRG("SOL",X)'=$GET(DRG("SOL",X))
SET PSJDIFF=1
QUIT
End DoDot:1
+21 QUIT PSJDIFF
DN(X) ;
+1 ;Return the drug name from file 50
+2 QUIT $PIECE($GET(^PSDRUG(+X,0)),U)
OI(X) ;
+1 ;Return the Orderable name from file 50.7
+2 NEW PSJX
+3 SET PSJX=$PIECE($GET(^PS(50.7,+X,0)),U)
+4 QUIT $SELECT(PSJX="":"Invalid Orderable Item",1:PSJX)
LINE(PSJLINE,PSJLEN) ;Display a line
+1 ;PSJLINE - type of line (ex: '-', '=")
+2 ;PSJLEN - the length of line
+3 SET X=""
SET $PIECE(X,PSJLINE,PSJLEN)=""
+4 WRITE X
+5 QUIT
DD53P45() ;Return the zero node of the first dispense drug found in 53.45
+1 ;Calling routine needs to clean up PSJALLGY array.
+2 NEW PSJDD,PSJDD1,PSJDD0,X,PSJX,PSGDT,%
+3 DO NOW^%DTC
SET PSGDT=%
+4 SET PSJDD=""
SET PSJDD1=""
+5 IF '+$GET(PSJSYSP)
QUIT ""
+6 FOR X=0:0
SET X=$ORDER(^PS(53.45,+PSJSYSP,2,X))
if '+X
QUIT
Begin DoDot:1
+7 SET PSJDD0=$GET(^PS(53.45,PSJSYSP,2,X,0))
+8 SET PSJX=$PIECE(PSJDD0,U,3)
IF PSJX]""
IF (PSJX'>$GET(PSGDT))
SET PSJDD0=""
QUIT
+9 SET PSJDD=+PSJDD0
+10 SET PSJX=$SELECT('$DATA(^PSDRUG(+PSJDD,0)):1,$PIECE($GET(^(2)),U,3)'["U":1,$GET(^("I"))="":0,1:^("I")'>$GET(PSGDT))
+11 IF PSJX
SET PSJDD0=""
SET PSJDD=""
QUIT
+12 SET PSJALLGY(PSJDD)=""
+13 if PSJDD1=""
SET PSJDD1=PSJDD0
End DoDot:1
+14 QUIT $GET(PSJDD1)
RETQUIT() ;
+1 ;Return 1 If enter "^"
+2 NEW DIR,DIROUT,DTOUT,DUOUT,PSJQUIT
+3 SET PSJQUIT=0
+4 SET DIR(0)="FO^1:1"
SET DIR("A")="Press RETURN to continue or '^' to exit"
+5 SET DIR("?")="Enter '^' to quit or any keys to continue"
+6 DO ^DIR
+7 IF $SELECT($DATA(DIROUT):1,$DATA(DUOUT):1,$DATA(DTOUT):1,1:0)
SET PSJQUIT=1
+8 QUIT PSJQUIT
PAUSE(PSJFIRST,PSJLAST) ;
+1 ;PSJFIRST - Print a blank line before the pause prompt
+2 ;PSJLAST - Print a blank line after the pause prompt
+3 KILL DIR
if +$GET(PSJFIRST)
WRITE !
SET DIR(0)="EA"
SET DIR("A")="Press Return to continue..."
SET DIR("?")="Press Return to continue..."
DO ^DIR
if +$GET(PSJLAST)
WRITE !
+4 QUIT
PAUSE1() ;Allow "^"
+1 ;Return 0 if X=""
+2 ;Return 1 if X="^"
+3 ;Return 2 if Not null or "^"
+4 NEW DIR,DIRUT,DUOUT,X
+5 KILL DIR
SET DIR("A")="Press RETURN to continue or ""^"" to display the next Monograph or ""^^"" to Exit"
+6 SET DIR("?")="Enter ""^"" to go to next Monograph, ""^^"" to exit the Monograph display."
+7 SET DIR(0)="FOU^^K:(X'="""")!(X'[""^"") X"
+8 DO ^DIR
+9 IF X=""
QUIT 0
+10 IF X="^"
QUIT 1
+11 QUIT 2
ONCALL(PSJSCH,PSJSTYPE) ;
+1 ; PSJSCH = Admin Schedule
+2 ; PSJSTYPE = schedule type (optional)
+3 ; Returns 0 = Not an "ON CALL" schedule.
+4 ; 1 = For schedule ="ON CALL" or schedule type = "OC".
+5 if $GET(PSJSTYPE)="OC"
QUIT 1
+6 if $GET(PSJSCH)=""
QUIT 0
+7 IF PSJSCH="ON CALL"!(PSJSCH="ONCALL")!(PSJSCH="ON-CALL")
QUIT 1
+8 QUIT 0
TMPDRG(DFN,ON,TMPDRG) ;Set TMPDRG array from the order in 55
+1 ;ON - IV order #
+2 NEW DRGT,FIL,Y,ND,DRG,DRGI
+3 if '+$GET(ON)
QUIT
+4 FOR DRGT="AD","SOL"
SET FIL=$SELECT(DRGT="AD":52.6,1:52.7)
FOR Y=0:0
SET Y=$ORDER(^PS(55,DFN,"IV",+ON,DRGT,Y))
if 'Y
QUIT
Begin DoDot:1
+5 ; naked ref below refers to line above
+6 SET DRG=$GET(^(Y,0))
SET ND=$GET(^PS(FIL,+DRG,0))
SET (DRGI,TMPDRG(DRGT,0))=$GET(TMPDRG(DRGT,0))+1
+7 SET TMPDRG(DRGT,+DRGI)=+DRG_U_$PIECE(ND,U)_U_$PIECE(DRG,U,2)_U_$PIECE(DRG,U,3)_U_$PIECE(ND,U,13)_U_$PIECE(ND,U,11)
End DoDot:1
+8 QUIT
TMPDRG1(DFN,ON,TMPDRG) ;Set TMPDRG array from the order in 53.1
+1 ;ON - IV order #
+2 NEW DRGT,FIL,Y,ND,DRG,DRGI
+3 if '+$GET(ON)
QUIT
+4 IF $PIECE(^PS(53.1,+ON,0),U,15)'=DFN
QUIT
+5 FOR DRGT="AD","SOL"
SET FIL=$SELECT(DRGT="AD":52.6,1:52.7)
FOR Y=0:0
SET Y=$ORDER(^PS(53.1,+ON,DRGT,Y))
if 'Y
QUIT
Begin DoDot:1
+6 ; naked ref below refers to line above
+7 SET DRG=$GET(^(Y,0))
SET ND=$GET(^PS(FIL,+DRG,0))
SET (DRGI,TMPDRG(DRGT,0))=$GET(TMPDRG(DRGT,0))+1
+8 SET TMPDRG(DRGT,+DRGI)=+DRG_U_$PIECE(ND,U)_U_$PIECE(DRG,U,2)_U_$PIECE(DRG,U,3)_U_$PIECE(ND,U,13)_U_$PIECE(ND,U,11)
End DoDot:1
+9 QUIT
INFRATE(DFN,ON,PSJIR,PSJDTYP) ;Check if the infusion rate has changed
+1 ;ON - ON_P/V
+2 ;PSJIR - infusion rate
+3 ;PSJDTYP - IV type. Only check infusion rate on continuous IV type
+4 NEW X,PSJONIR
+5 IF '$DATA(PSJDTYP)!(+$GET(PSJDTYP)=1)
QUIT 0
+6 IF '+$GET(ON)
QUIT 0
+7 IF $GET(PSJIR)=""
QUIT 0
+8 IF ON["V"
SET X=$GET(^PS(55,DFN,"IV",+ON,0))
SET PSJONIR=$PIECE(X,U,8)
+9 IF ON["P"
SET X=$GET(^PS(53.1,+ON,8))
SET PSJONIR=$PIECE(X,U,5)
+10 IF PSJONIR=""
QUIT 0
+11 IF PSJIR'=PSJONIR
QUIT 1
+12 QUIT 0
ADDD(PSJOI) ;Return the best dispense drug IEN for giving OI from the additive file
+1 ;PSJOI - 50.7 ien
+2 ;Output - 50 ien^52.6 ien or null
+3 ;PSJLIST(S1,S2) - sort by Use for IV fluid first
+4 ; S1=1 for active DD & has GCN; 2=active DD; 3=inactive DD;
+5 ; 4=active DD & has GCN; 5=active DD;6=inactive DD; S2 - DDIEN
+6 if '+$GET(PSJOI)
QUIT
+7 NEW PSJOK,PSIVIEN,PSIVIEN0,PSJINACT,PSJDDX,PSJACTDD,PSJGCN,PSJLIST,PSJFLUID
+8 SET PSJOK=0
+9 FOR PSIVIEN=0:0
SET PSIVIEN=$ORDER(^PS(52.6,"AOI",PSJOI,PSIVIEN))
if 'PSIVIEN
QUIT
if PSJOK
QUIT
Begin DoDot:1
+10 SET PSJACTDD=1
SET PSJGCN=0
SET PSJFLUID=0
+11 SET PSJINACT=$GET(^PS(52.6,PSIVIEN,"I"))
+12 IF PSJINACT]""
IF (PSJINACT'>DT)
QUIT
+13 SET PSIVIEN0=$GET(^PS(52.6,PSIVIEN,0))
+14 IF PSIVIEN0]""
Begin DoDot:2
+15 SET PSJDD=+$PIECE(PSIVIEN0,U,2)
+16 SET PSJINACT=$GET(^PSDRUG(PSJDD,"I"))
+17 IF PSJINACT]""
IF (PSJINACT'>DT)
SET PSJACTDD=0
+18 IF $PIECE(PSIVIEN0,U,13)
SET PSJFLUID=1
+19 IF +$$GCN^PSJMISC(PSJDD)
SET PSJGCN=1
End DoDot:2
+20 IF PSJFLUID
Begin DoDot:2
+21 IF PSJACTDD
IF PSJGCN
SET PSJLIST(1,PSJDD)=PSIVIEN
SET PSJOK=1
QUIT
+22 IF PSJACTDD
SET PSJLIST(2,PSJDD)=PSIVIEN
QUIT
+23 IF PSJDD
SET PSJLIST(3,PSJDD)=PSIVIEN
End DoDot:2
+24 IF 'PSJFLUID
Begin DoDot:2
+25 IF PSJACTDD
IF PSJGCN
SET PSJLIST(4,PSJDD)=PSIVIEN
QUIT
+26 IF PSJACTDD
SET PSJLIST(5,PSJDD)=PSIVIEN
QUIT
+27 IF PSJDD
SET PSJLIST(6,PSJDD)=PSIVIEN
End DoDot:2
End DoDot:1
+28 IF '$DATA(PSJLIST)
QUIT ""
+29 SET (PSJDD,PSSIEN)=0
SET PSJDDX=$ORDER(PSJLIST(0))
+30 IF +PSJDDX
SET PSJDD=$ORDER(PSJLIST(PSJDDX,0))
SET PSIVIEN=PSJLIST(PSJDDX,PSJDD)
QUIT PSJDD_U_PSIVIEN
+31 QUIT ""
SOLDD(PSJOI,PSJVOL) ;Return the best dispense drug IEN for giving OI from the solution file
+1 ;PSJOI - 50.7 ien
+2 ;Output - 50 ien^52.7 ien or null
+3 ;PSJLIST(s1,s2) - Set the list for the drugs in specific criteria for a best drug to use for dosing check
+4 ; sort by Use for IV fluid first
+5 ; IV fluid: s1: 1 - premix, active dd & matche; 2 - premix & active dd; 3 - premix ; 4 - inactive dd
+6 ; Not IV fluid: 5 - premix, active dd & matche; 6 - premix & active dd; 7 - premix ; 8 - inactive dd; s2 - Sol ien
+7 ;note - Only select sol entries with the exact volume.
+8 if '+$GET(PSJOI)
QUIT
+9 NEW PSJOK,PSIVIEN,PSJINACT,PSJDDX,PSJACTDD,PSJGCN,PSJLIST,PSJPREMX,PSJSOL,PSJFLUID
+10 SET PSJOK=0
SET PSJFLUID=0
+11 FOR PSIVIEN=0:0
SET PSIVIEN=$ORDER(^PS(52.7,"AOI",PSJOI,PSIVIEN))
if 'PSIVIEN
QUIT
if PSJOK
QUIT
Begin DoDot:1
+12 SET PSJACTDD=1
SET PSJGCN=0
SET PSJPREMX=0
+13 SET PSJINACT=$GET(^PS(52.7,PSIVIEN,"I"))
+14 IF PSJINACT]""
IF (PSJINACT'>DT)
QUIT
+15 ;Q if volume isn't matched
+16 SET PSJSOL=$GET(^PS(52.7,PSIVIEN,0))
+17 IF +$PIECE(PSJSOL,U,3)'=+PSJVOL
QUIT
+18 SET PSJDD=+$PIECE($GET(^PS(52.7,+PSIVIEN,0)),U,2)
+19 SET PSJINACT=$GET(^PSDRUG(PSJDD,"I"))
+20 IF PSJINACT]""
IF (PSJINACT'>DT)
SET PSJACTDD=0
+21 IF +$$GCN^PSJMISC(PSJDD)
SET PSJGCN=1
+22 IF +$$PREMIX^PSJMISC(PSJDD)
SET PSJPREMX=1
+23 IF +$PIECE(PSJSOL,U,13)
SET PSJFLUID=1
+24 IF PSJFLUID
Begin DoDot:2
+25 IF PSJPREMX
IF PSJACTDD
IF PSJGCN
SET PSJLIST(1,PSJDD)=PSIVIEN
SET PSJOK=1
QUIT
+26 IF PSJPREMX
IF PSJACTDD
SET PSJLIST(2,PSJDD)=PSIVIEN
QUIT
+27 IF PSJPREMX
SET PSJLIST(3,PSJDD)=PSIVIEN
QUIT
+28 IF PSJDD
SET PSJLIST(4,PSJDD)=PSIVIEN
End DoDot:2
+29 IF 'PSJFLUID
Begin DoDot:2
+30 IF PSJPREMX
IF PSJACTDD
IF PSJGCN
SET PSJLIST(5,PSJDD)=PSIVIEN
QUIT
+31 IF PSJPREMX
IF PSJACTDD
SET PSJLIST(6,PSJDD)=PSIVIEN
QUIT
+32 IF PSJPREMX
SET PSJLIST(7,PSJDD)=PSIVIEN
QUIT
+33 IF PSJDD
SET PSJLIST(8,PSJDD)=PSIVIEN
End DoDot:2
End DoDot:1
+34 IF '$DATA(PSJLIST)
QUIT ""
+35 SET (PSJDD,PSSIEN)=0
SET PSJDDX=$ORDER(PSJLIST(0))
+36 IF +PSJDDX
SET PSJDD=$ORDER(PSJLIST(PSJDDX,0))
SET PSIVIEN=PSJLIST(PSJDDX,PSJDD)
QUIT PSJDD_U_PSIVIEN
+37 QUIT ""
