PSGSICH1 ;BIR/JCH-PROVIDER & PHARMACY OVERRIDE UTILITIES 1; 01/25/11 1:02pm
;;5.0;INPATIENT MEDICATIONS;**254,281**;16 DEC 97;Build 113
;
; Reference to OCAPI^ORCHECK is supported by DBIA #4859.
; Reference to OCCNT^ORACPI1 is supported by DBIA #5637
; Reference to ^APSPQA(32.4 is supported by DBIA #2179
;
GETPROVL(PSGP,PSGORD,OUTARRAY) ; Get LAST (most recent) Provider Override associated with Inpatient Order
K OUTARRAY,PSJOCHIS,PSJQUITD,PSJHISTF,PSJOVRAR
N PSJDSPLN,ILCNT,PSJOVRAR,PSJCUROV,PSJCURIN,PSJTMPX,PSJTMPI,PSJINTAR,PSJINTER,PSJOVDON,PSJDONED,PSJINDEN,PSJBANNR,PSJHISTF,PSJHISTO,PSJIOSL,X,Y,DR,DIR,DIE,DIC,PSJOROIC
Q:'$G(PSGP)!'$G(PSGORD)
D GETOORDS^PSGSICH2(PSGP,PSGORD,.PSJOVRAR)
S PSJOROIC=$$OROICHK^PSGSICH(PSGP,PSGORD,.PSJOVRAR)
S PSJTMPX="" F S PSJTMPX=$O(PSJOVRAR(PSGP,PSGORD,PSJTMPX),-1) Q:'PSJTMPX!$G(PSJOVDON) D
.S PSJCUROV="" F S PSJCUROV=$O(PSJOVRAR(PSGP,PSGORD,PSJTMPX,PSJCUROV),-1) Q:'PSJCUROV!$G(PSJOVDON) D
..I PSJCUROV["C",(PSJCUROV'>PSJOROIC) S PSJOVDON=1 Q
..Q:(PSJCUROV)'["C" Q:'$$OCCNT^OROCAPI1(+PSJCUROV)
..N PSJTMPOO S PSJTMPOO=$G(PSJOVRAR(PSGP,PSGORD,PSJTMPX,PSJCUROV))
..D GETPROVR(PSGP,PSJTMPOO,.OUTARRAY,+PSJCUROV)
..I $D(OUTARRAY)>1 S PSJOVDON=1
K ^TMP($J,"PSJ")
Q
;
GETPROVR(PSGP,PSGORD,OUTARRAY,PSJCPRS) ; Get Provider Override
; Input: PSGP - Patient DFN (IEN from Pharmacy Patient (#55) file.
; PSGORD - Inpatient Order number from Pharmacy Patient (#55) file or NON-VERIFIED ORDERS (#53.1) file
; OUTARRAY - Name of array in which override data will be returned
; PSJCPRS - CPRS Order (#100) file IEN from which to retrieve Provider Override
Q:$G(PSJNEWOE)
N PSJ,DELIM,TXT,TXT1,TXT2,CAT K OUTARRAY,^TMP($J,"PSJ") S OUTARRAY=""
S PSJCPRS=$S($G(PSJCPRS):PSJCPRS,PSGORD["U":$P($G(^PS(55,PSGP,5,+PSGORD,0)),U,21),PSGORD["V":$P($G(^PS(55,PSGP,"IV",+PSGORD,0)),U,21),PSGORD["P":$P($G(^PS(53.1,+PSGORD,0)),U,21),1:0)
Q:'$G(PSJCPRS)
D OCAPI^ORCHECK(+PSJCPRS,"PSJ"):$G(PSJCPRS)
I PSJCPRS,$G(^TMP($J,"PSJ",1,"OC TEXT",1,0))'="" D
.S PSJ=0 F S PSJ=$O(^TMP($J,"PSJ",PSJ)) Q:'PSJ D
..S TXT=$G(^TMP($J,"PSJ",PSJ,"OC TEXT",1,0))
..S CAT=3 S:TXT["CRITICAL drug-drug" CAT=2
..S:(TXT["Previous ")&(TXT[" adverse reaction") CAT=1 ;;cmf/281 change
..;;S:TXT["Previous adverse reaction" CAT=1 ;;cmf/281 removal
..I TXT]"" S OUTARRAY("PROVR",PSGP,+PSGORD,CAT,PSJ,0)=TXT
.S PSJ=$O(^TMP($J,"PSJ",0))
.D NAME^PSGSICH($G(^TMP($J,"PSJ",PSJ,"OR PROVIDER")),.X)
.I X'="" S (TMPOAR,OUTARRAY("PROV",PSGP,+PSGORD,1))="Override Entered By: "_X D
..N PSJTITLE S PSJTITLE=$P($G(^VA(200,+^TMP($J,"PSJ",PSJ,"OR PROVIDER"),0)),"^",9) I PSJTITLE D
...N DIC,X,Y S DIC="^DIC(3.1,",DIC(0)="NZ" S X="`"_+PSJTITLE D ^DIC I Y S TMPOAR=TMPOAR_" ("_$P(Y,"^",2)_")"
..S OUTARRAY("PROV",PSGP,+PSGORD,1)=TMPOAR
..S X=$G(^TMP($J,"PSJ",PSJ,"OR DT")) I X D
...N PSJIDTMP S PSJIDTMP=$P($TR($$FMTE^XLFDT(X,2),"@"," "),":",1,2) S $P(PSJIDTMP,"/")=$S($L($P(PSJIDTMP,"/"))=1:0,1:"")_+$P(PSJIDTMP,"/") S $P(PSJIDTMP,"/",2)=$S($L($P(PSJIDTMP,"/",2))=1:0,1:"")_+$P(PSJIDTMP,"/",2)
...S OUTARRAY("PROV",PSGP,+PSGORD,2)=" Date/Time Entered: "_PSJIDTMP
..S OUTARRAY("PROV",PSGP,+PSGORD,3)=" Override Reason: "_$G(^TMP($J,"PSJ",PSJ,"OR REASON"))
..N TMPRV,TMPRVNAM S TMPRV=$S(PSGORD["U":$P($G(^PS(55,+PSGP,5,+PSGORD,0)),"^",2),PSGORD["P":$P($G(^PS(53.1,+PSGORD,0)),"^",2),PSGORD["V":$P($G(^PS(55,PSGP,"IV",+PSGORD,0)),"^",6),1:"") D
...S TMPRVNAM="" D NAME^PSGSICH(TMPRV,.TMPRVNAM) Q:TMPRVNAM=""
...S PSJTITLE=$P($G(^VA(200,+TMPRV,0)),"^",9) I PSJTITLE N DIC,X,Y S DIC="^DIC(3.1,",DIC(0)="NZ" S X="`"_+PSJTITLE D ^DIC I Y S PSJTITLE=$P(Y,"^",2)
...I PSJTITLE]"" S TMPRVNAM=TMPRVNAM_" ("_PSJTITLE_")"
..S OUTARRAY("PROV",PSGP,+PSGORD,0)="Overriding Provider: "_$G(TMPRVNAM)
I $G(OUTARRAY("PROV",PSGP,+PSGORD,0))=""!('$D(OUTARRAY("PROVR",PSGP,+PSGORD,1))&'$D(OUTARRAY("PROVR",PSGP,+PSGORD,2))) K OUTARRAY S OUTARRAY=""
K ^TMP($J,"PSJ")
Q
;
DSPROVR(PSGP,PSGORD,OUTARRAY) ; Display Provider Overrides
; INPUT: PSGP - Patient DFN
; PSGORD - Inpatient Order
; OUTARRAY - Array containing Provider Overrides
Q:$G(PSJNEWOE)!$G(PSJQUITD)
Q:$D(OUTARRAY)<10
N PSJDSPLN,TXT2,OCCNT,PSJL,PSJNXT,PSJINDEN,PSJBANNR,PSJIOSL,II,I2,JJ,OC,PSJM
S PSJIOSL=$S($G(IOSL):IOSL,1:24)
S PSJBANNR="Provider Overrides for this order" S PSJBANNR=$S($G(PSJOCHIS):"Historical ",1:"Current ")_PSJBANNR
S $P(PSJDSPLN,"=",76)="=",PSJINDEN=8
W !!,PSJDSPLN,!?PSJINDEN,"** ",PSJBANNR," **",!,PSJDSPLN,! S OCCNT=6
F II=0:1:3 W !,$G(OUTARRAY("PROV",PSGP,+PSGORD,II)) S OCCNT=$G(OCCNT)+1
W ! S CAT=0 F S CAT=$O(OUTARRAY("PROVR",PSGP,+PSGORD,CAT)) Q:'CAT D
.I $G(OCCNT)<4 W !!,PSJDSPLN,!?PSJINDEN,"** ",PSJBANNR," **",!,PSJDSPLN,! S OCCNT=5
.S OC=0 F S OC=$O(OUTARRAY("PROVR",PSGP,+PSGORD,CAT,OC)) Q:'OC!$G(PSJQUITD) D
..I $G(OCCNT)<4 W !!,PSJDSPLN,!?PSJINDEN,"** ",PSJBANNR," **",!,PSJDSPLN,! S OCCNT=5
..S PSJL=OUTARRAY("PROVR",PSGP,+PSGORD,CAT,OC,0) I $L(PSJL)>77 D
...F II=1:1 D S PSJL=PSJM Q:PSJL=""
....S PSJM=$E(PSJL,79,999),PSJL=$E(PSJL,1,78) I PSJM="",PSJL]"" S OUTARRAY("PROVR",PSGP,+PSGORD,CAT,OC,0,II)=PSJL Q
....S PSJDONED=0 F I2=$L(PSJL):-1:1 Q:$G(PSJDONED) I $E(PSJL,I2)=" " S PSJM=$E(PSJL,I2+1,$L(PSJL))_PSJM,PSJL=$E(PSJL,1,I2) S OUTARRAY("PROVR",PSGP,+PSGORD,CAT,OC,0,II)=PSJL,PSJDONED=1
...S PSJNXT=0 F S PSJNXT=$O(OUTARRAY("PROVR",PSGP,+PSGORD,CAT,OC,0,PSJNXT)) Q:'PSJNXT!$G(PSJQUITD) W !?2,OUTARRAY("PROVR",PSGP,+PSGORD,CAT,OC,0,PSJNXT) S OCCNT=$G(OCCNT)+1
...W ! S OCCNT=$G(OCCNT)+1
..Q:$G(PSJQUITD)
..I $L(OUTARRAY("PROVR",PSGP,+PSGORD,CAT,OC,0))<78 W !?2,OUTARRAY("PROVR",PSGP,+PSGORD,CAT,OC,0),! S OCCNT=$G(OCCNT)+2
..I OCCNT>($G(PSJIOSL)-6) D
...S JJ=($G(PSJIOSL)-2)-OCCNT F II=1:1:JJ W !
...D HLD^PSGSICH S OCCNT=0
Q:$G(PSJQUITD)
I OCCNT>4 D
.I OCCNT<($G(PSJIOSL)) S JJ=($G(PSJIOSL)-2)-OCCNT F II=1:1:JJ W !
.D HLD^PSGSICH S OCCNT=0
K ^TMP($J,"PSJ")
Q
;
INTRDIC(PSGP,PSGORD,OUTARRAY,PSJCURIN) ; Retrieve Intervention IEN's for a specific order and store in array
; Input: PSGP - Patient IEN from PATIENT (#2b) file. (required).
; PSGORD - Inpatient Order from NON-VERIFIED ORDERS (#53.1) file or UD (#62) multiple or IV (#100) multiple of
; PHARMACY PATIENT (#55) file.(required)
; OUTARRAY - Array name, passed by reference, to hold return values.(required)
; PSJCURIN - Current intervention flag.
; PSJCURIN = 0 - Return all interventions associated with order PSGORD regardless of date/time.
; PSJCURIN = 1 - Only return interventions, associated with order PSGORD, logged on the most recent Intervention date/time.
; PSJCURIN = 2 - Only return interventions, associated with order PJORDER, logged on most recent date, if at least one CRITICAL DRUG-DRUG or ALLERGY ADR was logged on the most recent Intervention date/time.
;
N %,II,INT,FLDI,FLDE,WPLINE,INTERVEN,PSJIDTM,PSJCNDT,PSJINT,PSJCRAL,DA,D0,DIC,DR,DFN,PSJORDER K ^UTILITY("DIQ1",$J) K OUTARRAY S PSJINT="A",DFN=PSGP,PSJORDER=PSGORD
I $G(PSJCURIN)=2 Q:'$$INTCHKO(DFN,PSJORDER)
I PSJORDER["P" F II=1:1 S PSJINT=$O(^PS(53.1,+PSJORDER,11,PSJINT),-1) Q:'PSJINT S INTERVEN=$G(^PS(53.1,+PSJORDER,11,PSJINT,0)),PSJIDTM=$P(INTERVEN,"^",2) D
.S:(II=1) PSJCNDT=$P(INTERVEN,"^",2) I $G(PSJCURIN)>0 Q:(PSJCNDT'=PSJIDTM)
.D ONEINTER^PSGSICH(INTERVEN,PSJORDER,PSJIDTM,.OUTARRAY)
I PSJORDER["U" F II=1:1 S PSJINT=$O(^PS(55,DFN,5,+PSJORDER,10,PSJINT),-1) Q:'PSJINT S INTERVEN=$G(^PS(55,DFN,5,+PSJORDER,10,PSJINT,0)),PSJIDTM=$P(INTERVEN,"^",2) D
.S:(II=1) PSJCNDT=$P(INTERVEN,"^",2) I $G(PSJCURIN)>0 Q:(PSJCNDT'=PSJIDTM)
.D ONEINTER^PSGSICH(INTERVEN,PSJORDER,PSJIDTM,.OUTARRAY)
I PSJORDER["V" F II=1:1 S PSJINT=$O(^PS(55,DFN,"IV",+PSJORDER,8,PSJINT),-1) Q:'PSJINT S INTERVEN=$G(^PS(55,DFN,"IV",+PSJORDER,8,PSJINT,0)),PSJIDTM=$P(INTERVEN,"^",2) D
.S:(II=1) PSJCNDT=$P(INTERVEN,"^",2) I $G(PSJCURIN)>0 Q:(PSJCNDT'=PSJIDTM)
.D ONEINTER^PSGSICH(INTERVEN,PSJORDER,PSJIDTM,.OUTARRAY)
K PSJCURIN
Q
;
OVRCHK(PSGP,PSGORD) ; If any Provider Overrides or Pharmacy Interventions exist for order, return 1, otherwise return 0.
; INPUT: PATIENT - Patient DFN
; ORDER - Inpatient order
Q:$D(^TMP("PSJINTER",$J)) 1
Q:'$G(PSGORD) 0
N TMPOC,TMPOCI,TMPFLG,FOUND,TMPOUTAR
I '$G(DFN) N DFN S DFN=PSGP
I $$INTCHKO(PSGP,PSGORD) Q 1
K TMPOUTAR D GETPROVL(PSGP,PSGORD,.TMPOUTAR)
I $O(TMPOUTAR("PROV","")) K TMPOUTAR Q 1
Q:$G(FOUND) 1
Q 0
;
INTCHKO(PSGP,PSGORD) ; If CRITICAL DRUG or ALLERGY Intervention exists for Inpatient order, return 1, otherwise return 0.
; INPUT: PATIENT - Patient DFN
; PSGORD - Inpatient order
N FOUND,PSJCRAL,II,PATIENT S FOUND=0
I PSGORD["P" S II=0 F S II=$O(^PS(53.1,+PSGORD,11,II)) Q:'II!FOUND D
.S INTERVEN=$G(^PS(53.1,+PSGORD,11,II,0)) S FOUND=$$INTCHK(+INTERVEN)
I PSGORD["U" S II=0 F S II=$O(^PS(55,PSGP,5,+PSGORD,10,II)) Q:'II!FOUND D
.S INTERVEN=$G(^PS(55,PSGP,5,+PSGORD,10,II,0)) S FOUND=$$INTCHK(+INTERVEN)
I PSGORD["V" S II=0 F S II=$O(^PS(55,PSGP,"IV",+PSGORD,8,II)) Q:'II!FOUND D
.S INTERVEN=$G(^PS(55,PSGP,"IV",+PSGORD,8,II,0)) S FOUND=$$INTCHK(+INTERVEN)
Q FOUND
;
INTCHK(INT) ; If classification of specific intervention is CRITICAL DRUG or ALLERGY/ADR, return 1, otherwise return 0
; INPUT: INT - Intervention IEN from the APSP Intervention (#9009032.4) file
Q:'$G(INT) 0
K PSJCRAL S PSJCRAL=0
I ",6,18,"[(","_$P($G(^APSPQA(32.4,+INT,0)),"^",7)_",") S PSJCRAL=1
Q PSJCRAL
;
BANNER(BANNER,PSJINDEN) ; Display Provider or Pharmacist Banner
W ! K PSJDSPLN S $P(PSJDSPLN,"=",76)="=" W !,PSJDSPLN S ILCNT=$G(ILCNT)+1
S PSJL="** "_BANNER_" **" W !?PSJINDEN,PSJL,!,PSJDSPLN S ILCNT=$G(ILCNT)+2
S PSJL=""
Q
;
STOREINT ; Store Intervention pointer to Inpatient order
Q:$G(ERR)=1
I '$G(PSGORD) N PSGORD S PSGORD=$S($G(ON):ON,$G(PSJORD):PSJORD,1:"")
Q:'PSGORD
N ACT,X,Y,INTII,PSJINTFL,INTIINUM,PSJINVDT,PSIVKEEP S PSJINTFL=0
I $G(PSGOORD)["U" S PSJINTFL=$G(^PS(55,PSGP,5,+PSGOORD,10,1,0)) I PSJINTFL,'$D(^TMP("PSJINTER",$J)) D
.;Don't carry over old interventions if OI changed
.I $G(PSGORD)["P" Q:(+$G(^PS(55,PSGP,5,+PSGOORD,.2))'=+$G(^PS(53.1,+PSGORD,.2)))
.; Don't carry over old interventions if OI changed
.I $G(PSGORD)["U" Q:(+$G(^PS(55,PSGP,5,+PSGOORD,.2))'=+$G(^PS(55,PSGP,5,+PSGORD,.2)))
.S INTII="A" F S INTII=$O(^PS(55,PSGP,5,+PSGOORD,10,INTII),-1) Q:'INTII S INTIINUM=$G(^(INTII,0)) I INTIINUM S ^TMP("PSJINTER",$J,+INTIINUM)=$P(INTIINUM,"^",2)_"^"_+$G(^PS(55,PSGP,5,+PSGOORD,.2))
I $G(PSGOORD)["P" S PSJINTFL=$G(^PS(53.1,+PSGOORD,11,1,0)) I PSJINTFL,'$D(^TMP("PSJINTER",$J)) D
.I $G(PSGORD)["P" Q:(+$G(^PS(53.1,+PSGOORD,.2))'=+$G(^PS(53.1,+PSGORD,.2))) ; Don't carry over old interventions if OI changed
.I $G(PSGORD)["U" Q:(+$G(^PS(53.1,+PSGOORD,.2))'=+$G(^PS(55,PSGP,5,+PSGORD,.2))) ; Don't carry over old interventions if OI changed
.S INTII="A" F S INTII=$O(^PS(53.1,+PSGOORD,11,INTII),-1) Q:'INTII S INTIINUM=$G(^(INTII,0)) I INTIINUM S ^TMP("PSJINTER",$J,+INTIINUM)=$P(INTIINUM,"^",2)_"^"_+$G(^PS(53.1,+PSGOORD,.2))
I $D(^TMP("PSJINTER",$J)),$G(PSGORD)["V",$D(^PS(55,PSGP,"IV",+PSGORD,8)) S PSIVKEEP=1 Q
I $D(^TMP("PSJINTER",$J)) S PSJINTER=0 F S PSJINTER=$O(^TMP("PSJINTER",$J,PSJINTER)) Q:'PSJINTER D
.N DR,DA,DIC,DIE,DD,DINUM,DO,KK N PSJOLIDT S PSJINVDT=+$G(^TMP("PSJINTER",$J,PSJINTER)) S:'PSJINVDT PSJINVDT=$G(PSGDT)
.I ($G(PSGORD)["V") N PSJIVODT S PSJIVODT=+$G(^PS(55,PSGP,"IV",+PSGORD,2)) I +$G(PSJINVDT)>(PSJIVODT)&($$FMDIFF^XLFDT(PSJINVDT,PSJIVODT,2)>90) S PSIVKEEP=1 Q
.I (PSGORD["V")!((PSGORD["P")&$D(^PS(53.1,+PSGORD,"AD"))) Q:'$$CHKADD^PSGSICH(PSJINTER,PSGP,PSGORD)
.I PSGORD["P" D
..N IC,IG S (IG,IC)=0 F Q:$G(IG) S IC=$O(^PS(53.1,+PSGORD,11,IC)) Q:'IC!$G(IG) S:(+$G(^PS(53.1,+PSGORD,11,IC,0))=+PSJINTER) IG=1
..Q:$G(IG) S DIC="^PS(53.1,"_+PSGORD_",11,",KK=$P($G(^PS(53.1,+PSGORD,11,0)),"^",3)+1 S DIC(0)="L",DIC("P")="53.13PA",DINUM=KK,DA(2)=+PSGORD,DA(1)=KK
..S X=+PSJINTER S DIC("DR")=".01////"_+PSJINTER_";1////"_PSJINVDT_";" D FILE^DICN
.I PSGORD["U" D
..S DIC="^PS(55,"_PSGP_",5,"_+PSGORD_",10," S KK=$P($G(^PS(55,PSGP,5,+PSGORD,10,0)),"^",3)+1 S DIC(0)="L",DIC("P")="55.6132PA"
..S DINUM=KK,DA(2)=PSGP,DA(1)=+PSGORD S X=+PSJINTER S DIC("DR")=".01////"_+PSJINTER_";1////"_PSJINVDT_";" D FILE^DICN
.I PSGORD["V" D
..S DIC="^PS(55,"_PSGP_",""IV"","_+PSGORD_",8," S KK=$P($G(^PS(55,PSGP,"IV",+PSGORD,8,0)),"^",3)+1 S DIC(0)="L",DIC("P")="55.1153PA"
..S DINUM=KK,DA(2)=PSGP,DA(1)=+PSGORD S X=+PSJINTER S DIC("DR")=".01////"_+PSJINTER_";1////"_PSJINVDT_";" D FILE^DICN
Q:$G(PSIVKEEP)
K ^TMP("PSJINTER",$J)
Q
;
SETIVINT ; Move intervention pointers from one order to another during finishing
Q:$G(ERR)=1 ; Order failed validation, don't move interventions
N DA,DIC,DR
I $G(PSGORD)["P" D K ^TMP("PSJINTER",$J) Q
.I ($G(ON)["V")!($G(ON)["P") D SETIVIN2^PSGSICH(PSGORD,ON) Q
I $G(PSJORD)["V" D
.I $G(ON)["P"!(($G(ON)["V")&($G(ON)'=$G(PSJORD))) D SETIVIN2^PSGSICH(PSJORD,ON) Q
I $G(PSJORD)["P" D
.I ($G(ON)["V")!($G(ON)["P") D SETIVIN2^PSGSICH(PSJORD,ON) Q
K ^TMP("PSJINTER",$J)
Q
;
SETUDINT(PSJU1,PSJU2) ; Store Intervention pointers in the UD intervention multiple
; INPUT: PSJU1 - Inpatient order from which to copy intervention pointer(s)
; PSJU2 - Inpatient order to copy intervention pointer(s) to
Q:'$G(DFN) N DA,DIC,PSJINTER,PSJINCNT,PSJNXTI,DO
I '$G(PSGDT) N PSGDT D NOW^%DTC S PSGDT=+$E(%,1,12)
I PSJU1["P" D
.I $G(PSJU2)["P" I $D(^PS(53.1,+PSJU1,11,0)),$D(^PS(53.1,+$G(PSJU2),0)) S PSJINCNT=+$P($G(^PS(53.1,+PSJU2,11,0)),"^",3) D Q
..S PSJNXTI=0 F S PSJNXTI=$O(^PS(53.1,+$G(PSJU1),11,PSJNXTI)) Q:'PSJNXTI S PSJINCNT=$G(PSJINCNT)+1 D
...S PSJINTER=$G(^PS(53.1,+$G(PSJU1),11,PSJNXTI,0)) Q:'PSJINTER Q:$D(^PS(53.1,+PSJU2,11,"B",+PSJINTER))
...S DIC="^PS(53.1,"_+PSJU2_",11,",DIC(0)="L",DIC("P")="53.13PA",DINUM=PSJINCNT,DA(1)=+PSJU2,DA=PSJINCNT
...S X=+PSJINTER,DIC("DR")=".01////"_+PSJINTER_";1////"_$G(PSGDT)_";" D FILE^DICN
.I '$G(PSJU2) S PSJU2=$P($G(^PS(53.1,+PSJU1,0)),"^",19) Q:'PSJU2 S PSJU2=PSJU2_"U"
.Q:(+$G(^PS(53.1,+PSJU1,.2))'=+$G(^PS(55,DFN,5,+PSJU2,.2))) ; Don't carry over old interventions if OI changed
.I $D(^PS(53.1,+PSJU1,11,0)),$D(^PS(55,DFN,5,+PSJU2,0)) S PSJINCNT=+$P($G(^PS(55,DFN,5,+PSJU2,10,0)),"^",3) D
..S PSJNXTI=0 F S PSJNXTI=$O(^PS(53.1,+$G(PSJU1),11,PSJNXTI)) Q:'PSJNXTI S PSJINCNT=$G(PSJINCNT)+1 D
...S PSJINTER=$G(^PS(53.1,+$G(PSJU1),11,PSJNXTI,0)) Q:'PSJINTER Q:$D(^PS(55,DFN,5,+$G(PSJU2),10,"B",+PSJINTER))
...S DIC="^PS(55,"_+DFN_",5,"_+PSJU2_",10,",DIC(0)="L",DIC("P")="55.6132PA",DA(1)=+PSJU2,DA(2)=DFN,(DINUM,X)=+PSJINCNT
...S DIC("DR")=".01////"_+PSJINTER_";1////"_$P(PSJINTER,"^",2)_";" D FILE^DICN
K ^TMP("PSJINTER",$J)
Q
;
ASKDISP() ; If Provider Overrides or Pharmacy Interventions exist, prompt user to display all.
N DIR,X,Y
I $G(PSJORD) Q:'$$OVRCHK($G(DFN),PSJORD) 0
I $G(PSJNEWOE),'$$ORDEXIST^PSGSICH(DFN,PSJORD) Q 0
W ! S DIR(0)="E",DIR("A")="Order Check Overrides/Interventions exist for this order. Display? (Y/N)",DIR("B")="Y",DIR(0)="Y" D ^DIR S:$G(Y)="" Y=1
Q $S(Y=1:1,1:0)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGSICH1 15251 printed Oct 16, 2024@18:04:01 Page 2
PSGSICH1 ;BIR/JCH-PROVIDER & PHARMACY OVERRIDE UTILITIES 1; 01/25/11 1:02pm
+1 ;;5.0;INPATIENT MEDICATIONS;**254,281**;16 DEC 97;Build 113
+2 ;
+3 ; Reference to OCAPI^ORCHECK is supported by DBIA #4859.
+4 ; Reference to OCCNT^ORACPI1 is supported by DBIA #5637
+5 ; Reference to ^APSPQA(32.4 is supported by DBIA #2179
+6 ;
GETPROVL(PSGP,PSGORD,OUTARRAY) ; Get LAST (most recent) Provider Override associated with Inpatient Order
+1 KILL OUTARRAY,PSJOCHIS,PSJQUITD,PSJHISTF,PSJOVRAR
+2 NEW PSJDSPLN,ILCNT,PSJOVRAR,PSJCUROV,PSJCURIN,PSJTMPX,PSJTMPI,PSJINTAR,PSJINTER,PSJOVDON,PSJDONED,PSJINDEN,PSJBANNR,PSJHISTF,PSJHISTO,PSJIOSL,X,Y,DR,DIR,DIE,DIC,PSJOROIC
+3 if '$GET(PSGP)!'$GET(PSGORD)
QUIT
+4 DO GETOORDS^PSGSICH2(PSGP,PSGORD,.PSJOVRAR)
+5 SET PSJOROIC=$$OROICHK^PSGSICH(PSGP,PSGORD,.PSJOVRAR)
+6 SET PSJTMPX=""
FOR
SET PSJTMPX=$ORDER(PSJOVRAR(PSGP,PSGORD,PSJTMPX),-1)
if 'PSJTMPX!$GET(PSJOVDON)
QUIT
Begin DoDot:1
+7 SET PSJCUROV=""
FOR
SET PSJCUROV=$ORDER(PSJOVRAR(PSGP,PSGORD,PSJTMPX,PSJCUROV),-1)
if 'PSJCUROV!$GET(PSJOVDON)
QUIT
Begin DoDot:2
+8 IF PSJCUROV["C"
IF (PSJCUROV'>PSJOROIC)
SET PSJOVDON=1
QUIT
+9 if (PSJCUROV)'["C"
QUIT
if '$$OCCNT^OROCAPI1(+PSJCUROV)
QUIT
+10 NEW PSJTMPOO
SET PSJTMPOO=$GET(PSJOVRAR(PSGP,PSGORD,PSJTMPX,PSJCUROV))
+11 DO GETPROVR(PSGP,PSJTMPOO,.OUTARRAY,+PSJCUROV)
+12 IF $DATA(OUTARRAY)>1
SET PSJOVDON=1
End DoDot:2
End DoDot:1
+13 KILL ^TMP($JOB,"PSJ")
+14 QUIT
+15 ;
GETPROVR(PSGP,PSGORD,OUTARRAY,PSJCPRS) ; Get Provider Override
+1 ; Input: PSGP - Patient DFN (IEN from Pharmacy Patient (#55) file.
+2 ; PSGORD - Inpatient Order number from Pharmacy Patient (#55) file or NON-VERIFIED ORDERS (#53.1) file
+3 ; OUTARRAY - Name of array in which override data will be returned
+4 ; PSJCPRS - CPRS Order (#100) file IEN from which to retrieve Provider Override
+5 if $GET(PSJNEWOE)
QUIT
+6 NEW PSJ,DELIM,TXT,TXT1,TXT2,CAT
KILL OUTARRAY,^TMP($JOB,"PSJ")
SET OUTARRAY=""
+7 SET PSJCPRS=$SELECT($GET(PSJCPRS):PSJCPRS,PSGORD["U":$PIECE($GET(^PS(55,PSGP,5,+PSGORD,0)),U,21),PSGORD["V":$PIECE($GET(^PS(55,PSGP,"IV",+PSGORD,0)),U,21),PSGORD["P":$PIECE($GET(^PS(53.1,+PSGORD,0)),U,21),1:0)
+8 if '$GET(PSJCPRS)
QUIT
+9 if $GET(PSJCPRS)
DO OCAPI^ORCHECK(+PSJCPRS,"PSJ")
+10 IF PSJCPRS
IF $GET(^TMP($JOB,"PSJ",1,"OC TEXT",1,0))'=""
Begin DoDot:1
+11 SET PSJ=0
FOR
SET PSJ=$ORDER(^TMP($JOB,"PSJ",PSJ))
if 'PSJ
QUIT
Begin DoDot:2
+12 SET TXT=$GET(^TMP($JOB,"PSJ",PSJ,"OC TEXT",1,0))
+13 SET CAT=3
if TXT["CRITICAL drug-drug"
SET CAT=2
+14 ;;cmf/281 change
if (TXT["Previous ")&(TXT[" adverse reaction")
SET CAT=1
+15 ;;S:TXT["Previous adverse reaction" CAT=1 ;;cmf/281 removal
+16 IF TXT]""
SET OUTARRAY("PROVR",PSGP,+PSGORD,CAT,PSJ,0)=TXT
End DoDot:2
+17 SET PSJ=$ORDER(^TMP($JOB,"PSJ",0))
+18 DO NAME^PSGSICH($GET(^TMP($JOB,"PSJ",PSJ,"OR PROVIDER")),.X)
+19 IF X'=""
SET (TMPOAR,OUTARRAY("PROV",PSGP,+PSGORD,1))="Override Entered By: "_X
Begin DoDot:2
+20 NEW PSJTITLE
SET PSJTITLE=$PIECE($GET(^VA(200,+^TMP($JOB,"PSJ",PSJ,"OR PROVIDER"),0)),"^",9)
IF PSJTITLE
Begin DoDot:3
+21 NEW DIC,X,Y
SET DIC="^DIC(3.1,"
SET DIC(0)="NZ"
SET X="`"_+PSJTITLE
DO ^DIC
IF Y
SET TMPOAR=TMPOAR_" ("_$PIECE(Y,"^",2)_")"
End DoDot:3
+22 SET OUTARRAY("PROV",PSGP,+PSGORD,1)=TMPOAR
+23 SET X=$GET(^TMP($JOB,"PSJ",PSJ,"OR DT"))
IF X
Begin DoDot:3
+24 NEW PSJIDTMP
SET PSJIDTMP=$PIECE($TRANSLATE($$FMTE^XLFDT(X,2),"@"," "),":",1,2)
SET $PIECE(PSJIDTMP,"/")=$SELECT($LENGTH($PIECE(PSJIDTMP,"/"))=1:0,1:"")_+$PIECE(PSJIDTMP,"/")
SET $PIECE(PSJIDTMP,"/",2)=$SELECT($LENGTH($PIECE(PSJIDTMP,"/",2))=1:0,1:"")_+$PIECE(PSJIDTMP,"/",2)
+25 SET OUTARRAY("PROV",PSGP,+PSGORD,2)=" Date/Time Entered: "_PSJIDTMP
End DoDot:3
+26 SET OUTARRAY("PROV",PSGP,+PSGORD,3)=" Override Reason: "_$GET(^TMP($JOB,"PSJ",PSJ,"OR REASON"))
+27 NEW TMPRV,TMPRVNAM
SET TMPRV=$SELECT(PSGORD["U":$PIECE($GET(^PS(55,+PSGP,5,+PSGORD,0)),"^",2),PSGORD["P":$PIECE($GET(^PS(53.1,+PSGORD,0)),"^",2),PSGORD["V":$PIECE($GET(^PS(55,PSGP,"IV",+PSGORD,0)),"^",6),1:"")
Begin DoDot:3
+28 SET TMPRVNAM=""
DO NAME^PSGSICH(TMPRV,.TMPRVNAM)
if TMPRVNAM=""
QUIT
+29 SET PSJTITLE=$PIECE($GET(^VA(200,+TMPRV,0)),"^",9)
IF PSJTITLE
NEW DIC,X,Y
SET DIC="^DIC(3.1,"
SET DIC(0)="NZ"
SET X="`"_+PSJTITLE
DO ^DIC
IF Y
SET PSJTITLE=$PIECE(Y,"^",2)
+30 IF PSJTITLE]""
SET TMPRVNAM=TMPRVNAM_" ("_PSJTITLE_")"
End DoDot:3
+31 SET OUTARRAY("PROV",PSGP,+PSGORD,0)="Overriding Provider: "_$GET(TMPRVNAM)
End DoDot:2
End DoDot:1
+32 IF $GET(OUTARRAY("PROV",PSGP,+PSGORD,0))=""!('$DATA(OUTARRAY("PROVR",PSGP,+PSGORD,1))&'$DATA(OUTARRAY("PROVR",PSGP,+PSGORD,2)))
KILL OUTARRAY
SET OUTARRAY=""
+33 KILL ^TMP($JOB,"PSJ")
+34 QUIT
+35 ;
DSPROVR(PSGP,PSGORD,OUTARRAY) ; Display Provider Overrides
+1 ; INPUT: PSGP - Patient DFN
+2 ; PSGORD - Inpatient Order
+3 ; OUTARRAY - Array containing Provider Overrides
+4 if $GET(PSJNEWOE)!$GET(PSJQUITD)
QUIT
+5 if $DATA(OUTARRAY)<10
QUIT
+6 NEW PSJDSPLN,TXT2,OCCNT,PSJL,PSJNXT,PSJINDEN,PSJBANNR,PSJIOSL,II,I2,JJ,OC,PSJM
+7 SET PSJIOSL=$SELECT($GET(IOSL):IOSL,1:24)
+8 SET PSJBANNR="Provider Overrides for this order"
SET PSJBANNR=$SELECT($GET(PSJOCHIS):"Historical ",1:"Current ")_PSJBANNR
+9 SET $PIECE(PSJDSPLN,"=",76)="="
SET PSJINDEN=8
+10 WRITE !!,PSJDSPLN,!?PSJINDEN,"** ",PSJBANNR," **",!,PSJDSPLN,!
SET OCCNT=6
+11 FOR II=0:1:3
WRITE !,$GET(OUTARRAY("PROV",PSGP,+PSGORD,II))
SET OCCNT=$GET(OCCNT)+1
+12 WRITE !
SET CAT=0
FOR
SET CAT=$ORDER(OUTARRAY("PROVR",PSGP,+PSGORD,CAT))
if 'CAT
QUIT
Begin DoDot:1
+13 IF $GET(OCCNT)<4
WRITE !!,PSJDSPLN,!?PSJINDEN,"** ",PSJBANNR," **",!,PSJDSPLN,!
SET OCCNT=5
+14 SET OC=0
FOR
SET OC=$ORDER(OUTARRAY("PROVR",PSGP,+PSGORD,CAT,OC))
if 'OC!$GET(PSJQUITD)
QUIT
Begin DoDot:2
+15 IF $GET(OCCNT)<4
WRITE !!,PSJDSPLN,!?PSJINDEN,"** ",PSJBANNR," **",!,PSJDSPLN,!
SET OCCNT=5
+16 SET PSJL=OUTARRAY("PROVR",PSGP,+PSGORD,CAT,OC,0)
IF $LENGTH(PSJL)>77
Begin DoDot:3
+17 FOR II=1:1
Begin DoDot:4
+18 SET PSJM=$EXTRACT(PSJL,79,999)
SET PSJL=$EXTRACT(PSJL,1,78)
IF PSJM=""
IF PSJL]""
SET OUTARRAY("PROVR",PSGP,+PSGORD,CAT,OC,0,II)=PSJL
QUIT
+19 SET PSJDONED=0
FOR I2=$LENGTH(PSJL):-1:1
if $GET(PSJDONED)
QUIT
IF $EXTRACT(PSJL,I2)=" "
SET PSJM=$EXTRACT(PSJL,I2+1,$LENGTH(PSJL))_PSJM
SET PSJL=$EXTRACT(PSJL,1,I2)
SET OUTARRAY("PROVR",PSGP,+PSGORD,CAT,OC,0,II)=PSJL
SET PSJDONED=1
End DoDot:4
SET PSJL=PSJM
if PSJL=""
QUIT
+20 SET PSJNXT=0
FOR
SET PSJNXT=$ORDER(OUTARRAY("PROVR",PSGP,+PSGORD,CAT,OC,0,PSJNXT))
if 'PSJNXT!$GET(PSJQUITD)
QUIT
WRITE !?2,OUTARRAY("PROVR",PSGP,+PSGORD,CAT,OC,0,PSJNXT)
SET OCCNT=$GET(OCCNT)+1
+21 WRITE !
SET OCCNT=$GET(OCCNT)+1
End DoDot:3
+22 if $GET(PSJQUITD)
QUIT
+23 IF $LENGTH(OUTARRAY("PROVR",PSGP,+PSGORD,CAT,OC,0))<78
WRITE !?2,OUTARRAY("PROVR",PSGP,+PSGORD,CAT,OC,0),!
SET OCCNT=$GET(OCCNT)+2
+24 IF OCCNT>($GET(PSJIOSL)-6)
Begin DoDot:3
+25 SET JJ=($GET(PSJIOSL)-2)-OCCNT
FOR II=1:1:JJ
WRITE !
+26 DO HLD^PSGSICH
SET OCCNT=0
End DoDot:3
End DoDot:2
End DoDot:1
+27 if $GET(PSJQUITD)
QUIT
+28 IF OCCNT>4
Begin DoDot:1
+29 IF OCCNT<($GET(PSJIOSL))
SET JJ=($GET(PSJIOSL)-2)-OCCNT
FOR II=1:1:JJ
WRITE !
+30 DO HLD^PSGSICH
SET OCCNT=0
End DoDot:1
+31 KILL ^TMP($JOB,"PSJ")
+32 QUIT
+33 ;
INTRDIC(PSGP,PSGORD,OUTARRAY,PSJCURIN) ; Retrieve Intervention IEN's for a specific order and store in array
+1 ; Input: PSGP - Patient IEN from PATIENT (#2b) file. (required).
+2 ; PSGORD - Inpatient Order from NON-VERIFIED ORDERS (#53.1) file or UD (#62) multiple or IV (#100) multiple of
+3 ; PHARMACY PATIENT (#55) file.(required)
+4 ; OUTARRAY - Array name, passed by reference, to hold return values.(required)
+5 ; PSJCURIN - Current intervention flag.
+6 ; PSJCURIN = 0 - Return all interventions associated with order PSGORD regardless of date/time.
+7 ; PSJCURIN = 1 - Only return interventions, associated with order PSGORD, logged on the most recent Intervention date/time.
+8 ; PSJCURIN = 2 - Only return interventions, associated with order PJORDER, logged on most recent date, if at least one CRITICAL DRUG-DRUG or ALLERGY ADR was logged on the most recent Intervention date/time.
+9 ;
+10 NEW %,II,INT,FLDI,FLDE,WPLINE,INTERVEN,PSJIDTM,PSJCNDT,PSJINT,PSJCRAL,DA,D0,DIC,DR,DFN,PSJORDER
KILL ^UTILITY("DIQ1",$JOB)
KILL OUTARRAY
SET PSJINT="A"
SET DFN=PSGP
SET PSJORDER=PSGORD
+11 IF $GET(PSJCURIN)=2
if '$$INTCHKO(DFN,PSJORDER)
QUIT
+12 IF PSJORDER["P"
FOR II=1:1
SET PSJINT=$ORDER(^PS(53.1,+PSJORDER,11,PSJINT),-1)
if 'PSJINT
QUIT
SET INTERVEN=$GET(^PS(53.1,+PSJORDER,11,PSJINT,0))
SET PSJIDTM=$PIECE(INTERVEN,"^",2)
Begin DoDot:1
+13 if (II=1)
SET PSJCNDT=$PIECE(INTERVEN,"^",2)
IF $GET(PSJCURIN)>0
if (PSJCNDT'=PSJIDTM)
QUIT
+14 DO ONEINTER^PSGSICH(INTERVEN,PSJORDER,PSJIDTM,.OUTARRAY)
End DoDot:1
+15 IF PSJORDER["U"
FOR II=1:1
SET PSJINT=$ORDER(^PS(55,DFN,5,+PSJORDER,10,PSJINT),-1)
if 'PSJINT
QUIT
SET INTERVEN=$GET(^PS(55,DFN,5,+PSJORDER,10,PSJINT,0))
SET PSJIDTM=$PIECE(INTERVEN,"^",2)
Begin DoDot:1
+16 if (II=1)
SET PSJCNDT=$PIECE(INTERVEN,"^",2)
IF $GET(PSJCURIN)>0
if (PSJCNDT'=PSJIDTM)
QUIT
+17 DO ONEINTER^PSGSICH(INTERVEN,PSJORDER,PSJIDTM,.OUTARRAY)
End DoDot:1
+18 IF PSJORDER["V"
FOR II=1:1
SET PSJINT=$ORDER(^PS(55,DFN,"IV",+PSJORDER,8,PSJINT),-1)
if 'PSJINT
QUIT
SET INTERVEN=$GET(^PS(55,DFN,"IV",+PSJORDER,8,PSJINT,0))
SET PSJIDTM=$PIECE(INTERVEN,"^",2)
Begin DoDot:1
+19 if (II=1)
SET PSJCNDT=$PIECE(INTERVEN,"^",2)
IF $GET(PSJCURIN)>0
if (PSJCNDT'=PSJIDTM)
QUIT
+20 DO ONEINTER^PSGSICH(INTERVEN,PSJORDER,PSJIDTM,.OUTARRAY)
End DoDot:1
+21 KILL PSJCURIN
+22 QUIT
+23 ;
OVRCHK(PSGP,PSGORD) ; If any Provider Overrides or Pharmacy Interventions exist for order, return 1, otherwise return 0.
+1 ; INPUT: PATIENT - Patient DFN
+2 ; ORDER - Inpatient order
+3 if $DATA(^TMP("PSJINTER",$JOB))
QUIT 1
+4 if '$GET(PSGORD)
QUIT 0
+5 NEW TMPOC,TMPOCI,TMPFLG,FOUND,TMPOUTAR
+6 IF '$GET(DFN)
NEW DFN
SET DFN=PSGP
+7 IF $$INTCHKO(PSGP,PSGORD)
QUIT 1
+8 KILL TMPOUTAR
DO GETPROVL(PSGP,PSGORD,.TMPOUTAR)
+9 IF $ORDER(TMPOUTAR("PROV",""))
KILL TMPOUTAR
QUIT 1
+10 if $GET(FOUND)
QUIT 1
+11 QUIT 0
+12 ;
INTCHKO(PSGP,PSGORD) ; If CRITICAL DRUG or ALLERGY Intervention exists for Inpatient order, return 1, otherwise return 0.
+1 ; INPUT: PATIENT - Patient DFN
+2 ; PSGORD - Inpatient order
+3 NEW FOUND,PSJCRAL,II,PATIENT
SET FOUND=0
+4 IF PSGORD["P"
SET II=0
FOR
SET II=$ORDER(^PS(53.1,+PSGORD,11,II))
if 'II!FOUND
QUIT
Begin DoDot:1
+5 SET INTERVEN=$GET(^PS(53.1,+PSGORD,11,II,0))
SET FOUND=$$INTCHK(+INTERVEN)
End DoDot:1
+6 IF PSGORD["U"
SET II=0
FOR
SET II=$ORDER(^PS(55,PSGP,5,+PSGORD,10,II))
if 'II!FOUND
QUIT
Begin DoDot:1
+7 SET INTERVEN=$GET(^PS(55,PSGP,5,+PSGORD,10,II,0))
SET FOUND=$$INTCHK(+INTERVEN)
End DoDot:1
+8 IF PSGORD["V"
SET II=0
FOR
SET II=$ORDER(^PS(55,PSGP,"IV",+PSGORD,8,II))
if 'II!FOUND
QUIT
Begin DoDot:1
+9 SET INTERVEN=$GET(^PS(55,PSGP,"IV",+PSGORD,8,II,0))
SET FOUND=$$INTCHK(+INTERVEN)
End DoDot:1
+10 QUIT FOUND
+11 ;
INTCHK(INT) ; If classification of specific intervention is CRITICAL DRUG or ALLERGY/ADR, return 1, otherwise return 0
+1 ; INPUT: INT - Intervention IEN from the APSP Intervention (#9009032.4) file
+2 if '$GET(INT)
QUIT 0
+3 KILL PSJCRAL
SET PSJCRAL=0
+4 IF ",6,18,"[(","_$PIECE($GET(^APSPQA(32.4,+INT,0)),"^",7)_",")
SET PSJCRAL=1
+5 QUIT PSJCRAL
+6 ;
BANNER(BANNER,PSJINDEN) ; Display Provider or Pharmacist Banner
+1 WRITE !
KILL PSJDSPLN
SET $PIECE(PSJDSPLN,"=",76)="="
WRITE !,PSJDSPLN
SET ILCNT=$GET(ILCNT)+1
+2 SET PSJL="** "_BANNER_" **"
WRITE !?PSJINDEN,PSJL,!,PSJDSPLN
SET ILCNT=$GET(ILCNT)+2
+3 SET PSJL=""
+4 QUIT
+5 ;
STOREINT ; Store Intervention pointer to Inpatient order
+1 if $GET(ERR)=1
QUIT
+2 IF '$GET(PSGORD)
NEW PSGORD
SET PSGORD=$SELECT($GET(ON):ON,$GET(PSJORD):PSJORD,1:"")
+3 if 'PSGORD
QUIT
+4 NEW ACT,X,Y,INTII,PSJINTFL,INTIINUM,PSJINVDT,PSIVKEEP
SET PSJINTFL=0
+5 IF $GET(PSGOORD)["U"
SET PSJINTFL=$GET(^PS(55,PSGP,5,+PSGOORD,10,1,0))
IF PSJINTFL
IF '$DATA(^TMP("PSJINTER",$JOB))
Begin DoDot:1
+6 ;Don't carry over old interventions if OI changed
+7 IF $GET(PSGORD)["P"
if (+$GET(^PS(55,PSGP,5,+PSGOORD,.2))'=+$GET(^PS(53.1,+PSGORD,.2)))
QUIT
+8 ; Don't carry over old interventions if OI changed
+9 IF $GET(PSGORD)["U"
if (+$GET(^PS(55,PSGP,5,+PSGOORD,.2))'=+$GET(^PS(55,PSGP,5,+PSGORD,.2)))
QUIT
+10 SET INTII="A"
FOR
SET INTII=$ORDER(^PS(55,PSGP,5,+PSGOORD,10,INTII),-1)
if 'INTII
QUIT
SET INTIINUM=$GET(^(INTII,0))
IF INTIINUM
SET ^TMP("PSJINTER",$JOB,+INTIINUM)=$PIECE(INTIINUM,"^",2)_"^"_+$GET(^PS(55,PSGP,5,+PSGOORD,.2))
End DoDot:1
+11 IF $GET(PSGOORD)["P"
SET PSJINTFL=$GET(^PS(53.1,+PSGOORD,11,1,0))
IF PSJINTFL
IF '$DATA(^TMP("PSJINTER",$JOB))
Begin DoDot:1
+12 ; Don't carry over old interventions if OI changed
IF $GET(PSGORD)["P"
if (+$GET(^PS(53.1,+PSGOORD,.2))'=+$GET(^PS(53.1,+PSGORD,.2)))
QUIT
+13 ; Don't carry over old interventions if OI changed
IF $GET(PSGORD)["U"
if (+$GET(^PS(53.1,+PSGOORD,.2))'=+$GET(^PS(55,PSGP,5,+PSGORD,.2)))
QUIT
+14 SET INTII="A"
FOR
SET INTII=$ORDER(^PS(53.1,+PSGOORD,11,INTII),-1)
if 'INTII
QUIT
SET INTIINUM=$GET(^(INTII,0))
IF INTIINUM
SET ^TMP("PSJINTER",$JOB,+INTIINUM)=$PIECE(INTIINUM,"^",2)_"^"_+$GET(^PS(53.1,+PSGOORD,.2))
End DoDot:1
+15 IF $DATA(^TMP("PSJINTER",$JOB))
IF $GET(PSGORD)["V"
IF $DATA(^PS(55,PSGP,"IV",+PSGORD,8))
SET PSIVKEEP=1
QUIT
+16 IF $DATA(^TMP("PSJINTER",$JOB))
SET PSJINTER=0
FOR
SET PSJINTER=$ORDER(^TMP("PSJINTER",$JOB,PSJINTER))
if 'PSJINTER
QUIT
Begin DoDot:1
+17 NEW DR,DA,DIC,DIE,DD,DINUM,DO,KK
NEW PSJOLIDT
SET PSJINVDT=+$GET(^TMP("PSJINTER",$JOB,PSJINTER))
if 'PSJINVDT
SET PSJINVDT=$GET(PSGDT)
+18 IF ($GET(PSGORD)["V")
NEW PSJIVODT
SET PSJIVODT=+$GET(^PS(55,PSGP,"IV",+PSGORD,2))
IF +$GET(PSJINVDT)>(PSJIVODT)&($$FMDIFF^XLFDT(PSJINVDT,PSJIVODT,2)>90)
SET PSIVKEEP=1
QUIT
+19 IF (PSGORD["V")!((PSGORD["P")&$DATA(^PS(53.1,+PSGORD,"AD")))
if '$$CHKADD^PSGSICH(PSJINTER,PSGP,PSGORD)
QUIT
+20 IF PSGORD["P"
Begin DoDot:2
+21 NEW IC,IG
SET (IG,IC)=0
FOR
if $GET(IG)
QUIT
SET IC=$ORDER(^PS(53.1,+PSGORD,11,IC))
if 'IC!$GET(IG)
QUIT
if (+$GET(^PS(53.1,+PSGORD,11,IC,0))=+PSJINTER)
SET IG=1
+22 if $GET(IG)
QUIT
SET DIC="^PS(53.1,"_+PSGORD_",11,"
SET KK=$PIECE($GET(^PS(53.1,+PSGORD,11,0)),"^",3)+1
SET DIC(0)="L"
SET DIC("P")="53.13PA"
SET DINUM=KK
SET DA(2)=+PSGORD
SET DA(1)=KK
+23 SET X=+PSJINTER
SET DIC("DR")=".01////"_+PSJINTER_";1////"_PSJINVDT_";"
DO FILE^DICN
End DoDot:2
+24 IF PSGORD["U"
Begin DoDot:2
+25 SET DIC="^PS(55,"_PSGP_",5,"_+PSGORD_",10,"
SET KK=$PIECE($GET(^PS(55,PSGP,5,+PSGORD,10,0)),"^",3)+1
SET DIC(0)="L"
SET DIC("P")="55.6132PA"
+26 SET DINUM=KK
SET DA(2)=PSGP
SET DA(1)=+PSGORD
SET X=+PSJINTER
SET DIC("DR")=".01////"_+PSJINTER_";1////"_PSJINVDT_";"
DO FILE^DICN
End DoDot:2
+27 IF PSGORD["V"
Begin DoDot:2
+28 SET DIC="^PS(55,"_PSGP_",""IV"","_+PSGORD_",8,"
SET KK=$PIECE($GET(^PS(55,PSGP,"IV",+PSGORD,8,0)),"^",3)+1
SET DIC(0)="L"
SET DIC("P")="55.1153PA"
+29 SET DINUM=KK
SET DA(2)=PSGP
SET DA(1)=+PSGORD
SET X=+PSJINTER
SET DIC("DR")=".01////"_+PSJINTER_";1////"_PSJINVDT_";"
DO FILE^DICN
End DoDot:2
End DoDot:1
+30 if $GET(PSIVKEEP)
QUIT
+31 KILL ^TMP("PSJINTER",$JOB)
+32 QUIT
+33 ;
SETIVINT ; Move intervention pointers from one order to another during finishing
+1 ; Order failed validation, don't move interventions
if $GET(ERR)=1
QUIT
+2 NEW DA,DIC,DR
+3 IF $GET(PSGORD)["P"
Begin DoDot:1
+4 IF ($GET(ON)["V")!($GET(ON)["P")
DO SETIVIN2^PSGSICH(PSGORD,ON)
QUIT
End DoDot:1
KILL ^TMP("PSJINTER",$JOB)
QUIT
+5 IF $GET(PSJORD)["V"
Begin DoDot:1
+6 IF $GET(ON)["P"!(($GET(ON)["V")&($GET(ON)'=$GET(PSJORD)))
DO SETIVIN2^PSGSICH(PSJORD,ON)
QUIT
End DoDot:1
+7 IF $GET(PSJORD)["P"
Begin DoDot:1
+8 IF ($GET(ON)["V")!($GET(ON)["P")
DO SETIVIN2^PSGSICH(PSJORD,ON)
QUIT
End DoDot:1
+9 KILL ^TMP("PSJINTER",$JOB)
+10 QUIT
+11 ;
SETUDINT(PSJU1,PSJU2) ; Store Intervention pointers in the UD intervention multiple
+1 ; INPUT: PSJU1 - Inpatient order from which to copy intervention pointer(s)
+2 ; PSJU2 - Inpatient order to copy intervention pointer(s) to
+3 if '$GET(DFN)
QUIT
NEW DA,DIC,PSJINTER,PSJINCNT,PSJNXTI,DO
+4 IF '$GET(PSGDT)
NEW PSGDT
DO NOW^%DTC
SET PSGDT=+$EXTRACT(%,1,12)
+5 IF PSJU1["P"
Begin DoDot:1
+6 IF $GET(PSJU2)["P"
IF $DATA(^PS(53.1,+PSJU1,11,0))
IF $DATA(^PS(53.1,+$GET(PSJU2),0))
SET PSJINCNT=+$PIECE($GET(^PS(53.1,+PSJU2,11,0)),"^",3)
Begin DoDot:2
+7 SET PSJNXTI=0
FOR
SET PSJNXTI=$ORDER(^PS(53.1,+$GET(PSJU1),11,PSJNXTI))
if 'PSJNXTI
QUIT
SET PSJINCNT=$GET(PSJINCNT)+1
Begin DoDot:3
+8 SET PSJINTER=$GET(^PS(53.1,+$GET(PSJU1),11,PSJNXTI,0))
if 'PSJINTER
QUIT
if $DATA(^PS(53.1,+PSJU2,11,"B",+PSJINTER))
QUIT
+9 SET DIC="^PS(53.1,"_+PSJU2_",11,"
SET DIC(0)="L"
SET DIC("P")="53.13PA"
SET DINUM=PSJINCNT
SET DA(1)=+PSJU2
SET DA=PSJINCNT
+10 SET X=+PSJINTER
SET DIC("DR")=".01////"_+PSJINTER_";1////"_$GET(PSGDT)_";"
DO FILE^DICN
End DoDot:3
End DoDot:2
QUIT
+11 IF '$GET(PSJU2)
SET PSJU2=$PIECE($GET(^PS(53.1,+PSJU1,0)),"^",19)
if 'PSJU2
QUIT
SET PSJU2=PSJU2_"U"
+12 ; Don't carry over old interventions if OI changed
if (+$GET(^PS(53.1,+PSJU1,.2))'=+$GET(^PS(55,DFN,5,+PSJU2,.2)))
QUIT
+13 IF $DATA(^PS(53.1,+PSJU1,11,0))
IF $DATA(^PS(55,DFN,5,+PSJU2,0))
SET PSJINCNT=+$PIECE($GET(^PS(55,DFN,5,+PSJU2,10,0)),"^",3)
Begin DoDot:2
+14 SET PSJNXTI=0
FOR
SET PSJNXTI=$ORDER(^PS(53.1,+$GET(PSJU1),11,PSJNXTI))
if 'PSJNXTI
QUIT
SET PSJINCNT=$GET(PSJINCNT)+1
Begin DoDot:3
+15 SET PSJINTER=$GET(^PS(53.1,+$GET(PSJU1),11,PSJNXTI,0))
if 'PSJINTER
QUIT
if $DATA(^PS(55,DFN,5,+$GET(PSJU2),10,"B",+PSJINTER))
QUIT
+16 SET DIC="^PS(55,"_+DFN_",5,"_+PSJU2_",10,"
SET DIC(0)="L"
SET DIC("P")="55.6132PA"
SET DA(1)=+PSJU2
SET DA(2)=DFN
SET (DINUM,X)=+PSJINCNT
+17 SET DIC("DR")=".01////"_+PSJINTER_";1////"_$PIECE(PSJINTER,"^",2)_";"
DO FILE^DICN
End DoDot:3
End DoDot:2
End DoDot:1
+18 KILL ^TMP("PSJINTER",$JOB)
+19 QUIT
+20 ;
ASKDISP() ; If Provider Overrides or Pharmacy Interventions exist, prompt user to display all.
+1 NEW DIR,X,Y
+2 IF $GET(PSJORD)
if '$$OVRCHK($GET(DFN),PSJORD)
QUIT 0
+3 IF $GET(PSJNEWOE)
IF '$$ORDEXIST^PSGSICH(DFN,PSJORD)
QUIT 0
+4 WRITE !
SET DIR(0)="E"
SET DIR("A")="Order Check Overrides/Interventions exist for this order. Display? (Y/N)"
SET DIR("B")="Y"
SET DIR(0)="Y"
DO ^DIR
if $GET(Y)=""
SET Y=1
+5 QUIT $SELECT(Y=1:1,1:0)
