- 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 Feb 18, 2025@23:29:37 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)