- 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 Jan 18, 2025@03:08:55 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 ""