- PSGSICH2 ;BIR/JCH-PROVIDER & PHARMACY OVERRIDE UTILITIES 2; 01/25/11 1:02pm
- ;;5.0;INPATIENT MEDICATIONS;**254**;16 DEC 97;Build 84
- ;
- ; Reference to OCCNT^OROCPI1 is supported by DBIA #5637
- ;
- INTROUT(INTER,PSJIDTM,PSJORDER,OUTARRAY) ; Build array of detailed intervention information
- N PSJFLDE,PSJFLDI,WPLINE
- S PSJFLDI=0 F S PSJFLDI=$O(^UTILITY("DIQ1",$J,9009032.4,INTER,PSJFLDI)) Q:'PSJFLDI D
- .D FIELD^DID(9009032.4,PSJFLDI,"","LABEL","PSJFLDE") S PSJFLDE=PSJFLDE("LABEL") I PSJFLDE]"" D
- ..N PC,TMPFLDE,TMPPC F PC=1:1:$L(PSJFLDE," ") S TMPPC=$$ENUL^PSGMI($P(PSJFLDE," ",PC)),$E(TMPPC)=$$ENLU^PSGMI($E(TMPPC)) S TMPFLDE=$G(TMPFLDE)_$S($G(TMPFLDE)]"":" ",1:"")_TMPPC
- ..S PSJFLDE=TMPFLDE
- .I PSJFLDI<1000 N DATA S DATA=$G(^UTILITY("DIQ1",$J,9009032.4,INTER,PSJFLDI,"E")) Q:DATA="" D Q
- ..I PSJFLDE["Intervention Date",$G(PSJIDTM) D Q
- ...N PSJIDTMP S PSJIDTMP=$P($TR($$FMTE^XLFDT(PSJIDTM,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(DFN,PSJORDER,INTER,PSJFLDI)=PSJFLDE_"/Time: "_PSJIDTMP Q
- ..S OUTARRAY(DFN,PSJORDER,INTER,PSJFLDI)=PSJFLDE_": "_DATA
- .I PSJFLDI>1000 S WPLINE=0 F S WPLINE=$O(^UTILITY("DIQ1",$J,9009032.4,INTER,PSJFLDI,WPLINE)) Q:'WPLINE D
- ..S OUTARRAY(DFN,PSJORDER,INTER,PSJFLDI,WPLINE)=^UTILITY("DIQ1",$J,9009032.4,INTER,PSJFLDI,WPLINE)
- ..I WPLINE=1 S OUTARRAY(DFN,PSJORDER,INTER,PSJFLDI,0)=PSJFLDE_": "
- Q
- INTRDICO(INTER) ; Retrieve Intervention data from APSP Intervention (#9009032.4) file
- N DIQ K ^UTILITY("DIQ1",$J)
- S DIC="^APSPQA(32.4,",DR=".01:1600",DA=INTER,DIQ(0)="E" D EN^DIQ1
- Q
- DSPINT(OUTARRAY,PSGORD) ;
- Q:$G(PSJQUITD)
- N PSJIOL,PSJBANNR,PSJINDEN,FLD,II,JJ,PSJL,PSJOCINT,PSJOCTXT,WP
- S PSJIOSL=$S($G(IOSL):IOSL,1:PSJIOSL),PSJINDEN=8
- D FULL^VALM1 W @IOF
- S PSJCOL=1,ILCNT=0,PSJBANNR=" Pharmacist Interventions for this order" S PSJBANNR=$S($G(PSJOCHIS):"Historical",1:"Current")_PSJBANNR
- W ! K LINE S $P(LINE,"=",76)="="
- S PSJL="** "_PSJBANNR_" **"
- I '$D(OUTARRAY(PSGP,PSGORD)) D BANNER^PSGSICH1(PSJL,PSJINDEN) W !,"No Pharmacist Interventions to display",!! S ILCNT=$G(ILCNT)+3 Q
- S PSJL="" S PSJOCINT=0 F S PSJOCINT=$O(OUTARRAY(PSGP,PSGORD,PSJOCINT)) Q:'PSJOCINT!$G(PSJQUITD) D
- .D BANNER^PSGSICH1(PSJBANNR,PSJINDEN)
- .I $D(PSJOVRAR("B",PSJOCINT_"I")) N TMPDT S TMPDT=$G(PSJOVRAR("B",PSJOCINT_"I")) K PSJOVRAR(PSGP,PSGORD,TMPDT,PSJOCINT_"I")
- .I PSJL]"" W PSJL S PSJL="",PSJCOL=1
- .S FLD=0 F II=1:1 S FLD=$O(OUTARRAY(PSGP,PSGORD,PSJOCINT,FLD)) Q:'FLD!$G(PSJQUITD) D
- ..I FLD<1000 D Q ; Store first column text left over
- ...S PSJOCTXT=OUTARRAY(PSGP,PSGORD,PSJOCINT,FLD) I PSJOCTXT["INTERVENTION DATE"!(PSJOCTXT["Intervention Date") S PSJL=PSJOCTXT W !!,PSJL S ILCNT=$G(ILCNT)+2,PSJL="" Q
- ...I PSJOCTXT["PATIENT:"!(PSJOCTXT["Patient") Q
- ...I ($L(PSJL)+$L(PSJOCTXT))>60 W !,PSJL S PSJL=" "_PSJOCTXT S ILCNT=$G(ILCNT)+1,PSJCOL=2 Q
- ...I $L(PSJL)=0 S PSJL=" "_PSJOCTXT,PSJCOL=2 Q
- ...S PSJL=$$SETSTR^VALM1(OUTARRAY(PSGP,PSGORD,PSJOCINT,FLD),PSJL,45,34) W !,PSJL S PSJL="",ILCNT=$G(ILCNT)+1,PSJCOL=1
- ..I $L(PSJL) W " ",PSJL S PSJL=""
- ..I FLD>1000 S PSJL="" S WP="" F JJ=1:1 S WP=$O(OUTARRAY(PSGP,PSGORD,PSJOCINT,FLD,WP)) Q:WP="" D
- ...S PSJL=" "_OUTARRAY(PSGP,PSGORD,PSJOCINT,FLD,WP) S:JJ>1 PSJL=" "_PSJL W !,PSJL S PSJL="" S ILCNT=$G(ILCNT)+1
- .I PSJL]"" W !,PSJL S PSJL="" S ILCNT=$G(ILCNT)+1
- .W ! S ILCNT=$G(ILCNT)+1 I $G(ILCNT)<($G(PSJIOSL)) S JJ=(($G(PSJIOSL)-2)-$G(ILCNT)) F II=1:1:JJ W ! S ILCNT=$G(ILCNT)+1
- .I $G(ILCNT)>($G(PSJIOSL)-3) D HLD^PSGSICH S ILCNT=0
- I $G(PSJL)]"" W PSJL S PSJL=""
- I $G(ILCNT)>1,($G(ILCNT)<($G(PSJIOSL))) S JJ=($G(PSJIOSL)-2)-$G(ILCNT) F II=1:1:JJ W ! S ILCNT=$G(ILCNT)+1
- I $G(ILCNT)>0 D HLD^PSGSICH S ILCNT=0
- K PSJCOL
- Q
- ;
- GETOORDS(DFN,PSGORCD,PSJORDS2) ; Get array of all historical CPRS orders associated with PSGORCD
- N PSJDONED,PSJRNFLG,PSJRN,PSJOERND,PSJOOERR,PSJNEWOI,PSJOLDOI S PSJDONED=0,PSJRNFLG=0 K PSJORDS2
- Q:'$G(DFN)!'$G(PSGORCD)
- S PSJPRVHD=$S(PSGORCD["V":$G(^PS(55,DFN,"IV",+PSGORCD,0)),PSGORCD["U":$G(^PS(55,DFN,5,+PSGORCD,0)),PSGORCD["P":$G(^PS(53.1,+PSGORCD,0)),1:"")
- S PSJORDT=$S(PSGORCD["V":$P($G(^PS(55,DFN,"IV",+PSGORCD,2)),"^"),1:$P(PSJPRVHD,"^",14))
- S PSJOOERR=$P(PSJPRVHD,"^",21) I PSJOOERR I '$D(PSJORDS2("B",+PSJOOERR_"C")) S PSJORDS2(+DFN,PSGORCD,+PSJORDT,+PSJOOERR_"C")=PSGORCD,PSJORDS2("B",+PSJOOERR_"C")=PSJORDT
- I PSGORCD["U" S PSJINT=0 F S PSJINT=$O(^PS(55,DFN,5,+PSGORCD,10,PSJINT)) Q:'PSJINT S PSJINTD=$G(^(PSJINT,0)) I PSJINTD,$P(PSJINTD,"^",2),'$D(PSJORDS2("B",+PSJINTD_"I")) D
- .S PSJORDS2(DFN,PSGORCD,+$P(PSJINTD,"^",2),+PSJINTD_"I")=PSGORCD,PSJORDS2("B",+PSJINTD_"I")=$P(PSJINTD,"^",2)
- I PSGORCD["P" S PSJINT=0 F S PSJINT=$O(^PS(53.1,+PSGORCD,11,PSJINT)) Q:'PSJINT S PSJINTD=$G(^(PSJINT,0)) I PSJINTD,$P(PSJINTD,"^",2),'$D(PSJORDS2("B",+PSJINTD_"I")) D
- .S PSJORDS2(DFN,PSGORCD,+$P(PSJINTD,"^",2),+PSJINTD_"I")=PSGORCD,PSJORDS2("B",+PSJINTD_"I")=$P(PSJINTD,"^",2)
- I PSGORCD["V" S PSJINT=0 F S PSJINT=$O(^PS(55,DFN,"IV",+PSGORCD,8,PSJINT)) Q:'PSJINT S PSJINTD=$G(^(PSJINT,0)) I PSJINTD,$P(PSJINTD,"^",2),'$D(PSJORDS2("B",+PSJINTD_"I")) D
- .S PSJORDS2(DFN,PSGORCD,+$P(PSJINTD,"^",2),+PSJINTD_"I")=PSGORCD,PSJORDS2("B",+PSJINTD_"I")=$P(PSJINTD,"^",2)
- S PSJPRV=PSGORCD I PSJPRV F Q:'PSJPRV!$G(PSJDONED) S PSJPRV=$S($G(PSJPRV)["V":$P($G(^PS(55,DFN,"IV",+PSJPRV,2)),"^",5),$G(PSJPRV)["U":$P($G(^PS(55,DFN,5,+PSJPRV,0)),"^",25),$G(PSJPRV)["P":$P($G(^PS(53.1,+PSJPRV,0)),"^",25),1:"") D
- .I PSJPRV=PSGORCD S PSJDONED=1 Q
- .S PSJPRVHD=$S(PSJPRV["V":$G(^PS(55,DFN,"IV",+PSJPRV,0)),PSJPRV["U":$G(^PS(55,DFN,5,+PSJPRV,0)),PSJPRV["P":$G(^PS(53.1,+PSJPRV,0)),1:"")
- .S PSJOOERR=$P(PSJPRVHD,"^",21) I 'PSJOOERR S PSJDONED=1 Q
- .S PSJORDT=$S(PSJPRV["V":$P($G(^PS(55,DFN,"IV",+PSJPRV,2)),"^"),1:$P(PSJPRVHD,"^",14)) I 'PSJORDT S PSJDONED=1 Q
- .I $P(PSJOOERR,";",2)=1,$D(PSJORDS2("B",+PSJOOERR_"C")) K PSJORDS2(DFN,PSGORCD,$G(PSJORDS2("B",+PSJOOERR_"C"))),PSJORDS2("B",+PSJOOERR_"C") D
- ..S PSJORDS2(DFN,PSGORCD,+PSJORDT,+PSJOOERR_"C")=PSJPRV,PSJORDS2("B",+PSJOOERR_"C")=PSJORDT
- .I '$D(PSJORDS2("B",+PSJOOERR_"C")) S PSJORDS2(DFN,PSGORCD,+PSJORDT,+PSJOOERR_"C")=PSJPRV,PSJORDS2("B",+PSJOOERR_"C")=PSJORDT
- .I PSJPRV["V" S PSJINT=0 F S PSJINT=$O(^PS(55,DFN,"IV",+PSJPRV,8,PSJINT)) Q:'PSJINT S PSJINTD=$G(^(PSJINT,0)) I PSJINTD,$P(PSJINTD,"^",2),'$D(PSJORDS2("B",+PSJINTD_"I")) D
- ..S PSJORDS2(DFN,PSGORCD,+$P(PSJINTD,"^",2),+PSJINTD_"I")=PSJPRV,PSJORDS2("B",+PSJINTD_"I")=$P(PSJINTD,"^",2)
- .I PSJPRV["U" S PSJINT=0 F S PSJINT=$O(^PS(55,DFN,5,+PSJPRV,10,PSJINT)) Q:'PSJINT S PSJINTD=$G(^(PSJINT,0)) I PSJINTD,$P(PSJINTD,"^",2),'$D(PSJORDS2("B",+PSJINTD_"I")) D
- ..S PSJORDS2(DFN,PSGORCD,+$P(PSJINTD,"^",2),+PSJINTD_"I")=PSJPRV,PSJORDS2("B",+PSJINTD_"I")=$P(PSJINTD,"^",2)
- .I PSJPRV["P" S PSJINT=0 F S PSJINT=$O(^PS(53.1,+PSJPRV,11,PSJINT)) Q:'PSJINT S PSJINTD=$G(^(PSJINT,0)) I PSJINTD,$P(PSJINTD,"^",2),'$D(PSJORDS2("B",+PSJINTD_"I")) D
- ..S PSJORDS2(DFN,PSGORCD,+$P(PSJINTD,"^",2),+PSJINTD_"I")=PSJPRV,PSJORDS2("B",+PSJINTD_"I")=$P(PSJINTD,"^",2)
- .D GETRNW(DFN,PSGORCD,PSJPRV,.PSJORDS2)
- D GETRNW(DFN,PSGORCD,PSGORCD,.PSJORDS2)
- K PSJIOR,PSJIDT,PSJO2,PSJINT,PSJINTD,PSJPRV,PSJPRVHD,PSJORDT
- Q
- GETRNW(DFN,PSJCUROR,PSJRNORD,PSJORDS2) ; Get CPRS orders from all renewals for order PSJRNORD
- I $D(^PS(55,DFN,5,+PSJRNORD,14,1,0)),PSJRNORD["U",'PSJRNFLG S PSJRNFLG=1 D
- .S PSJRN=0 F S PSJRN=$O(^PS(55,DFN,5,+PSJRNORD,14,PSJRN)) Q:'PSJRN S PSJOERND=$G(^(PSJRN,0)),PSJOOERR=$P(PSJOERND,"^",5),PSJORDT=$P(PSJOERND,"^") D
- ..Q:'PSJOOERR S PSJORDS2(DFN,PSJCUROR,+PSJORDT,+PSJOOERR_"C")=PSJRNORD,PSJORDS2("B",+PSJOOERR_"C")=PSJORDT
- I $D(^PS(55,DFN,"IV",+PSJRNORD,14,1,0)),PSJRNORD["V",'PSJRNFLG S PSJRNFLG=1 D
- .S PSJRN=0 F S PSJRN=$O(^PS(55,DFN,"IV",+PSJRNORD,14,PSJRN)) Q:'PSJRN S PSJOERND=$G(^(PSJRN,0)),PSJOOERR=$P(PSJOERND,"^",5),PSJORDT=$P(PSJOERND,"^") D
- ..Q:'PSJOOERR S PSJORDS2(DFN,PSGORCD,+PSJORDT,+PSJOOERR_"C")=PSJRNORD,PSJORDS2("B",+PSJOOERR_"C")=PSJORDT
- Q
- OVRDISF(PSGP,PSGORD,CODE) ; For Pending Orders, only display Provider Overrides and Pharmacy Interventions if new, incoming Provider Override to display
- N TMPOFLG,KK,PSJOVRAR,PSJORFOR Q:PSGORD'["P" S PSJORFOR=+$P($G(^PS(53.1,+PSGORD,0)),"^",21)
- D GETPROVR^PSGSICH1(PSGP,PSGORD,.PSJOVRAR,+PSJORFOR) F KK=1:1:2 I $D(PSJOVRAR("PROVR",PSGP,+PSGORD,KK)) S TMPOFLG=1
- K PSJOVRAR I $G(TMPOFLG) D OVRDISP(DFN,PSGORD,2)
- Q
- OVRDISP(PSGP,PSGORD,CODE) ; Display ALL Provider Overrides and Pharmacy Interventions associated with specific order
- K OUTARRAY,PSJOCHIS,PSJQUITD,PSJHISTF,TMPKILAR
- N LINE,ILCNT,PSJOVRAR,PSJCUROV,PSJCURIN,PSJTMPX,PSJTMPI,PSJINTAR,PSJINTER,PSJOVDON,PSJDONED,PSJINDEN,PSJBANNR,PSJHISTF,PSJHISTO,PSJIOSL,X,Y,DR,DIR,DIE,DIC,PSJOLDOR,PSJOLDOI,PSJNEWOI,PSJOROIC
- S:'$G(PSGORD) PSGORD=0 Q:'$G(PSGP)!('$G(PSGORD)&'$D(^TMP("PSJINTER",$J))) S PSJOVDON=0,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(LINE,"=",76)="=",PSJINDEN=8
- I $G(PSGORD) D GETOORDS(PSGP,PSGORD,.PSJOVRAR) S PSJOROIC=$$OROICHK^PSGSICH(PSGP,PSGORD,.PSJOVRAR)
- I $G(CODE)=2!($G(CODE)=3) D FULL^VALM1 W @IOF 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'>$G(PSJOROIC) S PSJOVDON=-1 Q
- ..Q:(PSJCUROV)'["C" Q:'$$OCCNT^OROCAPI1(+PSJCUROV)
- ..N PSJTMPOO S PSJTMPOO=$G(PSJOVRAR(PSGP,PSGORD,PSJTMPX,PSJCUROV))
- ..D GETPROVR^PSGSICH1(PSGP,PSJTMPOO,.OUTARRAY,+PSJCUROV)
- ..I $D(OUTARRAY)>1 W @IOF D DSPROVR^PSGSICH1(PSGP,PSJTMPOO,.OUTARRAY) K OUTARRAY S PSJOVDON=1 K PSJOVRAR("B",PSJCUROV)
- I $G(PSJOVDON)<1 W !!,LINE,!?PSJINDEN,"** ",PSJBANNR," **",!,LINE W !!,"No Provider Overrides to display",!!! D HLD^PSGSICH
- K OUTARRAY S OUTARRAY="" I $G(CODE)=2!$G(PSJQUITD) K PSJDONED Q
- I $G(PSGORD) D INTRDIC^PSGSICH1(PSGP,PSGORD,.OUTARRAY,1)
- ; New intervention to display, not yet attached to order?
- I $D(^TMP("PSJINTER",$J)) D
- .N I2 S I2="" F S I2=$O(^TMP("PSJINTER",$J,I2)) Q:'I2 D ONEINTER^PSGSICH(+I2,$G(PSGORD),$G(PSGDT),.OUTARRAY)
- I '$D(OUTARRAY(PSGP)) D
- .S PSJBANNR="Pharmacist Interventions for this order" S PSJBANNR=$S($G(PSJOCHIS):"Historical ",1:"Current ")_PSJBANNR
- .W !,LINE,!?PSJINDEN,"** "_PSJBANNR_" **",!,LINE,!!,"No Pharmacist Interventions to display",!! F KK=1:1:($G(PSJIOSL)-10) W !
- .D HLD^PSGSICH
- I $D(OUTARRAY)>1 D DSPINT(.OUTARRAY,$S($G(PSGORD):PSGORD,1:0))
- S PSJL="" W !,PSJL
- S (PSJHISTF,PSJHISTO)="" F S PSJHISTO=$O(PSJOVRAR("B",PSJHISTO)) Q:PSJHISTO=""!$G(PSJHISTF) D
- .N PSJOCDT S PSJOCDT=$G(PSJOVRAR("B",PSJHISTO)) Q:'PSJOCDT Q:'$D(PSJOVRAR(PSGP,$G(PSGORD),PSJOCDT,PSJHISTO))
- .I PSJHISTO["I" S PSJHISTF=1 Q
- .I PSJHISTF["C" K TMPOVR S TMPOVR="" D GETPROVR^PSGSICH1(PSGP,PSGORD,.TMPOVR,+PSJHISTO) S PSJHISTF=$D(TMPOVR)>1 K TMPOVR
- I $G(PSJHISTF) I $$HISTHLD() D FULL^VALM1 W @IOF D OVRHIST(.PSJOVRAR,PSGORD)
- K OUTARRAY,PSJOVRAR,PSJOCHIS,PSJDONED,PSJHIST
- Q
- OVRHIST(PSJOAR,PSGORCD) ; History of overrides/interventions using hidden action
- N PSJO1,PSJO2,PSJO3,PSJOERR,PSJOCHIS,FIRST,PSJIDT,PSJIOR,PSJIOSL S PSJOCHIS=1,FIRST=1,PSJIOSL=$S($G(IOSL):IOSL,1:24)
- S PSJO1="" F S PSJO1=$O(PSJOAR(PSGP,PSGORCD,PSJO1),-1) Q:PSJO1="" D
- .S PSJO2="" F S PSJO2=$O(PSJOAR(PSGP,PSGORCD,PSJO1,PSJO2),-1) Q:PSJO2="" D
- ..Q:'$D(PSJOAR("B",PSJO2)) ; This is the same as the 'current' provider override (multiple Inpatient orders can point to same CPRS order #)
- ..K PSJTMPAR S PSJTMPAR="" I PSJO2["C" S PSJO3=$G(PSJOAR(PSGP,PSGORCD,PSJO1,PSJO2)) I PSJO3 D Q
- ...Q:'$D(PSJOAR("B",PSJO2))
- ...D GETPROVR^PSGSICH1(PSGP,PSJO3,.PSJTMPAR,PSJO2) I $D(PSJTMPAR)>1 D DSPROVR^PSGSICH1(PSGP,PSJO3,.PSJTMPAR)
- ...K PSJOAR("B",PSJO2)
- ..K PSJTMPAR S PSJTMPAR="" I PSJO2["I" S PSJO3=$G(PSJOAR(PSGP,PSGORCD,PSJO1,PSJO2)) I PSJO3 D Q
- ...Q:'$D(PSJOAR("B",PSJO2))
- ...D ONEINTER^PSGSICH(PSJO2,PSJO3,PSJO1,.PSJTMPAR)
- ...I $D(PSJTMPAR)>1 D FULL^VALM1 W @IOF D DSPINT(.PSJTMPAR,PSJO3)
- ...K PSJOAR("B",PSJO2)
- K PSJTMPAR,PSJOCHIS,PSJQUITD,PSJO1,PSJO2,PSJO3
- Q
- HISTHLD() ;
- K DIR S DIR(0)="E",DIR("A")="View Historical Overrides/Interventions for this order (Y/N)",DIR("B")="Y",DIR(0)="Y" D ^DIR
- Q Y
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSGSICH2 12351 printed Feb 18, 2025@23:29:38 Page 2
- PSGSICH2 ;BIR/JCH-PROVIDER & PHARMACY OVERRIDE UTILITIES 2; 01/25/11 1:02pm
- +1 ;;5.0;INPATIENT MEDICATIONS;**254**;16 DEC 97;Build 84
- +2 ;
- +3 ; Reference to OCCNT^OROCPI1 is supported by DBIA #5637
- +4 ;
- INTROUT(INTER,PSJIDTM,PSJORDER,OUTARRAY) ; Build array of detailed intervention information
- +1 NEW PSJFLDE,PSJFLDI,WPLINE
- +2 SET PSJFLDI=0
- FOR
- SET PSJFLDI=$ORDER(^UTILITY("DIQ1",$JOB,9009032.4,INTER,PSJFLDI))
- if 'PSJFLDI
- QUIT
- Begin DoDot:1
- +3 DO FIELD^DID(9009032.4,PSJFLDI,"","LABEL","PSJFLDE")
- SET PSJFLDE=PSJFLDE("LABEL")
- IF PSJFLDE]""
- Begin DoDot:2
- +4 NEW PC,TMPFLDE,TMPPC
- FOR PC=1:1:$LENGTH(PSJFLDE," ")
- SET TMPPC=$$ENUL^PSGMI($PIECE(PSJFLDE," ",PC))
- SET $EXTRACT(TMPPC)=$$ENLU^PSGMI($EXTRACT(TMPPC))
- SET TMPFLDE=$GET(TMPFLDE)_$SELECT($GET(TMPFLDE)]"":" ",1:"")_TMPPC
- +5 SET PSJFLDE=TMPFLDE
- End DoDot:2
- +6 IF PSJFLDI<1000
- NEW DATA
- SET DATA=$GET(^UTILITY("DIQ1",$JOB,9009032.4,INTER,PSJFLDI,"E"))
- if DATA=""
- QUIT
- Begin DoDot:2
- +7 IF PSJFLDE["Intervention Date"
- IF $GET(PSJIDTM)
- Begin DoDot:3
- +8 NEW PSJIDTMP
- SET PSJIDTMP=$PIECE($TRANSLATE($$FMTE^XLFDT(PSJIDTM,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)
- +9 SET OUTARRAY(DFN,PSJORDER,INTER,PSJFLDI)=PSJFLDE_"/Time: "_PSJIDTMP
- QUIT
- End DoDot:3
- QUIT
- +10 SET OUTARRAY(DFN,PSJORDER,INTER,PSJFLDI)=PSJFLDE_": "_DATA
- End DoDot:2
- QUIT
- +11 IF PSJFLDI>1000
- SET WPLINE=0
- FOR
- SET WPLINE=$ORDER(^UTILITY("DIQ1",$JOB,9009032.4,INTER,PSJFLDI,WPLINE))
- if 'WPLINE
- QUIT
- Begin DoDot:2
- +12 SET OUTARRAY(DFN,PSJORDER,INTER,PSJFLDI,WPLINE)=^UTILITY("DIQ1",$JOB,9009032.4,INTER,PSJFLDI,WPLINE)
- +13 IF WPLINE=1
- SET OUTARRAY(DFN,PSJORDER,INTER,PSJFLDI,0)=PSJFLDE_": "
- End DoDot:2
- End DoDot:1
- +14 QUIT
- INTRDICO(INTER) ; Retrieve Intervention data from APSP Intervention (#9009032.4) file
- +1 NEW DIQ
- KILL ^UTILITY("DIQ1",$JOB)
- +2 SET DIC="^APSPQA(32.4,"
- SET DR=".01:1600"
- SET DA=INTER
- SET DIQ(0)="E"
- DO EN^DIQ1
- +3 QUIT
- DSPINT(OUTARRAY,PSGORD) ;
- +1 if $GET(PSJQUITD)
- QUIT
- +2 NEW PSJIOL,PSJBANNR,PSJINDEN,FLD,II,JJ,PSJL,PSJOCINT,PSJOCTXT,WP
- +3 SET PSJIOSL=$SELECT($GET(IOSL):IOSL,1:PSJIOSL)
- SET PSJINDEN=8
- +4 DO FULL^VALM1
- WRITE @IOF
- +5 SET PSJCOL=1
- SET ILCNT=0
- SET PSJBANNR=" Pharmacist Interventions for this order"
- SET PSJBANNR=$SELECT($GET(PSJOCHIS):"Historical",1:"Current")_PSJBANNR
- +6 WRITE !
- KILL LINE
- SET $PIECE(LINE,"=",76)="="
- +7 SET PSJL="** "_PSJBANNR_" **"
- +8 IF '$DATA(OUTARRAY(PSGP,PSGORD))
- DO BANNER^PSGSICH1(PSJL,PSJINDEN)
- WRITE !,"No Pharmacist Interventions to display",!!
- SET ILCNT=$GET(ILCNT)+3
- QUIT
- +9 SET PSJL=""
- SET PSJOCINT=0
- FOR
- SET PSJOCINT=$ORDER(OUTARRAY(PSGP,PSGORD,PSJOCINT))
- if 'PSJOCINT!$GET(PSJQUITD)
- QUIT
- Begin DoDot:1
- +10 DO BANNER^PSGSICH1(PSJBANNR,PSJINDEN)
- +11 IF $DATA(PSJOVRAR("B",PSJOCINT_"I"))
- NEW TMPDT
- SET TMPDT=$GET(PSJOVRAR("B",PSJOCINT_"I"))
- KILL PSJOVRAR(PSGP,PSGORD,TMPDT,PSJOCINT_"I")
- +12 IF PSJL]""
- WRITE PSJL
- SET PSJL=""
- SET PSJCOL=1
- +13 SET FLD=0
- FOR II=1:1
- SET FLD=$ORDER(OUTARRAY(PSGP,PSGORD,PSJOCINT,FLD))
- if 'FLD!$GET(PSJQUITD)
- QUIT
- Begin DoDot:2
- +14 ; Store first column text left over
- IF FLD<1000
- Begin DoDot:3
- +15 SET PSJOCTXT=OUTARRAY(PSGP,PSGORD,PSJOCINT,FLD)
- IF PSJOCTXT["INTERVENTION DATE"!(PSJOCTXT["Intervention Date")
- SET PSJL=PSJOCTXT
- WRITE !!,PSJL
- SET ILCNT=$GET(ILCNT)+2
- SET PSJL=""
- QUIT
- +16 IF PSJOCTXT["PATIENT:"!(PSJOCTXT["Patient")
- QUIT
- +17 IF ($LENGTH(PSJL)+$LENGTH(PSJOCTXT))>60
- WRITE !,PSJL
- SET PSJL=" "_PSJOCTXT
- SET ILCNT=$GET(ILCNT)+1
- SET PSJCOL=2
- QUIT
- +18 IF $LENGTH(PSJL)=0
- SET PSJL=" "_PSJOCTXT
- SET PSJCOL=2
- QUIT
- +19 SET PSJL=$$SETSTR^VALM1(OUTARRAY(PSGP,PSGORD,PSJOCINT,FLD),PSJL,45,34)
- WRITE !,PSJL
- SET PSJL=""
- SET ILCNT=$GET(ILCNT)+1
- SET PSJCOL=1
- End DoDot:3
- QUIT
- +20 IF $LENGTH(PSJL)
- WRITE " ",PSJL
- SET PSJL=""
- +21 IF FLD>1000
- SET PSJL=""
- SET WP=""
- FOR JJ=1:1
- SET WP=$ORDER(OUTARRAY(PSGP,PSGORD,PSJOCINT,FLD,WP))
- if WP=""
- QUIT
- Begin DoDot:3
- +22 SET PSJL=" "_OUTARRAY(PSGP,PSGORD,PSJOCINT,FLD,WP)
- if JJ>1
- SET PSJL=" "_PSJL
- WRITE !,PSJL
- SET PSJL=""
- SET ILCNT=$GET(ILCNT)+1
- End DoDot:3
- End DoDot:2
- +23 IF PSJL]""
- WRITE !,PSJL
- SET PSJL=""
- SET ILCNT=$GET(ILCNT)+1
- +24 WRITE !
- SET ILCNT=$GET(ILCNT)+1
- IF $GET(ILCNT)<($GET(PSJIOSL))
- SET JJ=(($GET(PSJIOSL)-2)-$GET(ILCNT))
- FOR II=1:1:JJ
- WRITE !
- SET ILCNT=$GET(ILCNT)+1
- +25 IF $GET(ILCNT)>($GET(PSJIOSL)-3)
- DO HLD^PSGSICH
- SET ILCNT=0
- End DoDot:1
- +26 IF $GET(PSJL)]""
- WRITE PSJL
- SET PSJL=""
- +27 IF $GET(ILCNT)>1
- IF ($GET(ILCNT)<($GET(PSJIOSL)))
- SET JJ=($GET(PSJIOSL)-2)-$GET(ILCNT)
- FOR II=1:1:JJ
- WRITE !
- SET ILCNT=$GET(ILCNT)+1
- +28 IF $GET(ILCNT)>0
- DO HLD^PSGSICH
- SET ILCNT=0
- +29 KILL PSJCOL
- +30 QUIT
- +31 ;
- GETOORDS(DFN,PSGORCD,PSJORDS2) ; Get array of all historical CPRS orders associated with PSGORCD
- +1 NEW PSJDONED,PSJRNFLG,PSJRN,PSJOERND,PSJOOERR,PSJNEWOI,PSJOLDOI
- SET PSJDONED=0
- SET PSJRNFLG=0
- KILL PSJORDS2
- +2 if '$GET(DFN)!'$GET(PSGORCD)
- QUIT
- +3 SET PSJPRVHD=$SELECT(PSGORCD["V":$GET(^PS(55,DFN,"IV",+PSGORCD,0)),PSGORCD["U":$GET(^PS(55,DFN,5,+PSGORCD,0)),PSGORCD["P":$GET(^PS(53.1,+PSGORCD,0)),1:"")
- +4 SET PSJORDT=$SELECT(PSGORCD["V":$PIECE($GET(^PS(55,DFN,"IV",+PSGORCD,2)),"^"),1:$PIECE(PSJPRVHD,"^",14))
- +5 SET PSJOOERR=$PIECE(PSJPRVHD,"^",21)
- IF PSJOOERR
- IF '$DATA(PSJORDS2("B",+PSJOOERR_"C"))
- SET PSJORDS2(+DFN,PSGORCD,+PSJORDT,+PSJOOERR_"C")=PSGORCD
- SET PSJORDS2("B",+PSJOOERR_"C")=PSJORDT
- +6 IF PSGORCD["U"
- SET PSJINT=0
- FOR
- SET PSJINT=$ORDER(^PS(55,DFN,5,+PSGORCD,10,PSJINT))
- if 'PSJINT
- QUIT
- SET PSJINTD=$GET(^(PSJINT,0))
- IF PSJINTD
- IF $PIECE(PSJINTD,"^",2)
- IF '$DATA(PSJORDS2("B",+PSJINTD_"I"))
- Begin DoDot:1
- +7 SET PSJORDS2(DFN,PSGORCD,+$PIECE(PSJINTD,"^",2),+PSJINTD_"I")=PSGORCD
- SET PSJORDS2("B",+PSJINTD_"I")=$PIECE(PSJINTD,"^",2)
- End DoDot:1
- +8 IF PSGORCD["P"
- SET PSJINT=0
- FOR
- SET PSJINT=$ORDER(^PS(53.1,+PSGORCD,11,PSJINT))
- if 'PSJINT
- QUIT
- SET PSJINTD=$GET(^(PSJINT,0))
- IF PSJINTD
- IF $PIECE(PSJINTD,"^",2)
- IF '$DATA(PSJORDS2("B",+PSJINTD_"I"))
- Begin DoDot:1
- +9 SET PSJORDS2(DFN,PSGORCD,+$PIECE(PSJINTD,"^",2),+PSJINTD_"I")=PSGORCD
- SET PSJORDS2("B",+PSJINTD_"I")=$PIECE(PSJINTD,"^",2)
- End DoDot:1
- +10 IF PSGORCD["V"
- SET PSJINT=0
- FOR
- SET PSJINT=$ORDER(^PS(55,DFN,"IV",+PSGORCD,8,PSJINT))
- if 'PSJINT
- QUIT
- SET PSJINTD=$GET(^(PSJINT,0))
- IF PSJINTD
- IF $PIECE(PSJINTD,"^",2)
- IF '$DATA(PSJORDS2("B",+PSJINTD_"I"))
- Begin DoDot:1
- +11 SET PSJORDS2(DFN,PSGORCD,+$PIECE(PSJINTD,"^",2),+PSJINTD_"I")=PSGORCD
- SET PSJORDS2("B",+PSJINTD_"I")=$PIECE(PSJINTD,"^",2)
- End DoDot:1
- +12 SET PSJPRV=PSGORCD
- IF PSJPRV
- FOR
- if 'PSJPRV!$GET(PSJDONED)
- QUIT
- SET PSJPRV=$SELECT($GET(PSJPRV)["V":$PIECE($GET(^PS(55,DFN,"IV",+PSJPRV,2)),"^",5),$GET(PSJPRV)["U":$PIECE($GET(^PS(55,DFN,5,+PSJPRV,0)),"^",25),$GET(PSJPRV)["P":$PIECE($GET(^PS(53.1,+PSJPRV,0)),"^",25),1:"")
- Begin DoDot:1
- +13 IF PSJPRV=PSGORCD
- SET PSJDONED=1
- QUIT
- +14 SET PSJPRVHD=$SELECT(PSJPRV["V":$GET(^PS(55,DFN,"IV",+PSJPRV,0)),PSJPRV["U":$GET(^PS(55,DFN,5,+PSJPRV,0)),PSJPRV["P":$GET(^PS(53.1,+PSJPRV,0)),1:"")
- +15 SET PSJOOERR=$PIECE(PSJPRVHD,"^",21)
- IF 'PSJOOERR
- SET PSJDONED=1
- QUIT
- +16 SET PSJORDT=$SELECT(PSJPRV["V":$PIECE($GET(^PS(55,DFN,"IV",+PSJPRV,2)),"^"),1:$PIECE(PSJPRVHD,"^",14))
- IF 'PSJORDT
- SET PSJDONED=1
- QUIT
- +17 IF $PIECE(PSJOOERR,";",2)=1
- IF $DATA(PSJORDS2("B",+PSJOOERR_"C"))
- KILL PSJORDS2(DFN,PSGORCD,$GET(PSJORDS2("B",+PSJOOERR_"C"))),PSJORDS2("B",+PSJOOERR_"C")
- Begin DoDot:2
- +18 SET PSJORDS2(DFN,PSGORCD,+PSJORDT,+PSJOOERR_"C")=PSJPRV
- SET PSJORDS2("B",+PSJOOERR_"C")=PSJORDT
- End DoDot:2
- +19 IF '$DATA(PSJORDS2("B",+PSJOOERR_"C"))
- SET PSJORDS2(DFN,PSGORCD,+PSJORDT,+PSJOOERR_"C")=PSJPRV
- SET PSJORDS2("B",+PSJOOERR_"C")=PSJORDT
- +20 IF PSJPRV["V"
- SET PSJINT=0
- FOR
- SET PSJINT=$ORDER(^PS(55,DFN,"IV",+PSJPRV,8,PSJINT))
- if 'PSJINT
- QUIT
- SET PSJINTD=$GET(^(PSJINT,0))
- IF PSJINTD
- IF $PIECE(PSJINTD,"^",2)
- IF '$DATA(PSJORDS2("B",+PSJINTD_"I"))
- Begin DoDot:2
- +21 SET PSJORDS2(DFN,PSGORCD,+$PIECE(PSJINTD,"^",2),+PSJINTD_"I")=PSJPRV
- SET PSJORDS2("B",+PSJINTD_"I")=$PIECE(PSJINTD,"^",2)
- End DoDot:2
- +22 IF PSJPRV["U"
- SET PSJINT=0
- FOR
- SET PSJINT=$ORDER(^PS(55,DFN,5,+PSJPRV,10,PSJINT))
- if 'PSJINT
- QUIT
- SET PSJINTD=$GET(^(PSJINT,0))
- IF PSJINTD
- IF $PIECE(PSJINTD,"^",2)
- IF '$DATA(PSJORDS2("B",+PSJINTD_"I"))
- Begin DoDot:2
- +23 SET PSJORDS2(DFN,PSGORCD,+$PIECE(PSJINTD,"^",2),+PSJINTD_"I")=PSJPRV
- SET PSJORDS2("B",+PSJINTD_"I")=$PIECE(PSJINTD,"^",2)
- End DoDot:2
- +24 IF PSJPRV["P"
- SET PSJINT=0
- FOR
- SET PSJINT=$ORDER(^PS(53.1,+PSJPRV,11,PSJINT))
- if 'PSJINT
- QUIT
- SET PSJINTD=$GET(^(PSJINT,0))
- IF PSJINTD
- IF $PIECE(PSJINTD,"^",2)
- IF '$DATA(PSJORDS2("B",+PSJINTD_"I"))
- Begin DoDot:2
- +25 SET PSJORDS2(DFN,PSGORCD,+$PIECE(PSJINTD,"^",2),+PSJINTD_"I")=PSJPRV
- SET PSJORDS2("B",+PSJINTD_"I")=$PIECE(PSJINTD,"^",2)
- End DoDot:2
- +26 DO GETRNW(DFN,PSGORCD,PSJPRV,.PSJORDS2)
- End DoDot:1
- +27 DO GETRNW(DFN,PSGORCD,PSGORCD,.PSJORDS2)
- +28 KILL PSJIOR,PSJIDT,PSJO2,PSJINT,PSJINTD,PSJPRV,PSJPRVHD,PSJORDT
- +29 QUIT
- GETRNW(DFN,PSJCUROR,PSJRNORD,PSJORDS2) ; Get CPRS orders from all renewals for order PSJRNORD
- +1 IF $DATA(^PS(55,DFN,5,+PSJRNORD,14,1,0))
- IF PSJRNORD["U"
- IF 'PSJRNFLG
- SET PSJRNFLG=1
- Begin DoDot:1
- +2 SET PSJRN=0
- FOR
- SET PSJRN=$ORDER(^PS(55,DFN,5,+PSJRNORD,14,PSJRN))
- if 'PSJRN
- QUIT
- SET PSJOERND=$GET(^(PSJRN,0))
- SET PSJOOERR=$PIECE(PSJOERND,"^",5)
- SET PSJORDT=$PIECE(PSJOERND,"^")
- Begin DoDot:2
- +3 if 'PSJOOERR
- QUIT
- SET PSJORDS2(DFN,PSJCUROR,+PSJORDT,+PSJOOERR_"C")=PSJRNORD
- SET PSJORDS2("B",+PSJOOERR_"C")=PSJORDT
- End DoDot:2
- End DoDot:1
- +4 IF $DATA(^PS(55,DFN,"IV",+PSJRNORD,14,1,0))
- IF PSJRNORD["V"
- IF 'PSJRNFLG
- SET PSJRNFLG=1
- Begin DoDot:1
- +5 SET PSJRN=0
- FOR
- SET PSJRN=$ORDER(^PS(55,DFN,"IV",+PSJRNORD,14,PSJRN))
- if 'PSJRN
- QUIT
- SET PSJOERND=$GET(^(PSJRN,0))
- SET PSJOOERR=$PIECE(PSJOERND,"^",5)
- SET PSJORDT=$PIECE(PSJOERND,"^")
- Begin DoDot:2
- +6 if 'PSJOOERR
- QUIT
- SET PSJORDS2(DFN,PSGORCD,+PSJORDT,+PSJOOERR_"C")=PSJRNORD
- SET PSJORDS2("B",+PSJOOERR_"C")=PSJORDT
- End DoDot:2
- End DoDot:1
- +7 QUIT
- OVRDISF(PSGP,PSGORD,CODE) ; For Pending Orders, only display Provider Overrides and Pharmacy Interventions if new, incoming Provider Override to display
- +1 NEW TMPOFLG,KK,PSJOVRAR,PSJORFOR
- if PSGORD'["P"
- QUIT
- SET PSJORFOR=+$PIECE($GET(^PS(53.1,+PSGORD,0)),"^",21)
- +2 DO GETPROVR^PSGSICH1(PSGP,PSGORD,.PSJOVRAR,+PSJORFOR)
- FOR KK=1:1:2
- IF $DATA(PSJOVRAR("PROVR",PSGP,+PSGORD,KK))
- SET TMPOFLG=1
- +3 KILL PSJOVRAR
- IF $GET(TMPOFLG)
- DO OVRDISP(DFN,PSGORD,2)
- +4 QUIT
- OVRDISP(PSGP,PSGORD,CODE) ; Display ALL Provider Overrides and Pharmacy Interventions associated with specific order
- +1 KILL OUTARRAY,PSJOCHIS,PSJQUITD,PSJHISTF,TMPKILAR
- +2 NEW LINE,ILCNT,PSJOVRAR,PSJCUROV,PSJCURIN,PSJTMPX,PSJTMPI,PSJINTAR,PSJINTER,PSJOVDON,PSJDONED,PSJINDEN,PSJBANNR,PSJHISTF,PSJHISTO,PSJIOSL,X,Y,DR,DIR,DIE,DIC,PSJOLDOR,PSJOLDOI,PSJNEWOI,PSJOROIC
- +3 if '$GET(PSGORD)
- SET PSGORD=0
- if '$GET(PSGP)!('$GET(PSGORD)&'$DATA(^TMP("PSJINTER",$JOB)))
- QUIT
- SET PSJOVDON=0
- SET PSJIOSL=$SELECT($GET(IOSL):IOSL,1:24)
- +4 SET PSJBANNR="Provider Overrides for this order"
- SET PSJBANNR=$SELECT($GET(PSJOCHIS):"Historical ",1:"Current ")_PSJBANNR
- +5 SET $PIECE(LINE,"=",76)="="
- SET PSJINDEN=8
- +6 IF $GET(PSGORD)
- DO GETOORDS(PSGP,PSGORD,.PSJOVRAR)
- SET PSJOROIC=$$OROICHK^PSGSICH(PSGP,PSGORD,.PSJOVRAR)
- +7 IF $GET(CODE)=2!($GET(CODE)=3)
- DO FULL^VALM1
- WRITE @IOF
- SET PSJTMPX=""
- FOR
- SET PSJTMPX=$ORDER(PSJOVRAR(PSGP,PSGORD,PSJTMPX),-1)
- if 'PSJTMPX!$GET(PSJOVDON)
- QUIT
- Begin DoDot:1
- +8 SET PSJCUROV=""
- FOR
- SET PSJCUROV=$ORDER(PSJOVRAR(PSGP,PSGORD,PSJTMPX,PSJCUROV),-1)
- if 'PSJCUROV!$GET(PSJOVDON)
- QUIT
- Begin DoDot:2
- +9 IF PSJCUROV'>$GET(PSJOROIC)
- SET PSJOVDON=-1
- QUIT
- +10 if (PSJCUROV)'["C"
- QUIT
- if '$$OCCNT^OROCAPI1(+PSJCUROV)
- QUIT
- +11 NEW PSJTMPOO
- SET PSJTMPOO=$GET(PSJOVRAR(PSGP,PSGORD,PSJTMPX,PSJCUROV))
- +12 DO GETPROVR^PSGSICH1(PSGP,PSJTMPOO,.OUTARRAY,+PSJCUROV)
- +13 IF $DATA(OUTARRAY)>1
- WRITE @IOF
- DO DSPROVR^PSGSICH1(PSGP,PSJTMPOO,.OUTARRAY)
- KILL OUTARRAY
- SET PSJOVDON=1
- KILL PSJOVRAR("B",PSJCUROV)
- End DoDot:2
- End DoDot:1
- +14 IF $GET(PSJOVDON)<1
- WRITE !!,LINE,!?PSJINDEN,"** ",PSJBANNR," **",!,LINE
- WRITE !!,"No Provider Overrides to display",!!!
- DO HLD^PSGSICH
- +15 KILL OUTARRAY
- SET OUTARRAY=""
- IF $GET(CODE)=2!$GET(PSJQUITD)
- KILL PSJDONED
- QUIT
- +16 IF $GET(PSGORD)
- DO INTRDIC^PSGSICH1(PSGP,PSGORD,.OUTARRAY,1)
- +17 ; New intervention to display, not yet attached to order?
- +18 IF $DATA(^TMP("PSJINTER",$JOB))
- Begin DoDot:1
- +19 NEW I2
- SET I2=""
- FOR
- SET I2=$ORDER(^TMP("PSJINTER",$JOB,I2))
- if 'I2
- QUIT
- DO ONEINTER^PSGSICH(+I2,$GET(PSGORD),$GET(PSGDT),.OUTARRAY)
- End DoDot:1
- +20 IF '$DATA(OUTARRAY(PSGP))
- Begin DoDot:1
- +21 SET PSJBANNR="Pharmacist Interventions for this order"
- SET PSJBANNR=$SELECT($GET(PSJOCHIS):"Historical ",1:"Current ")_PSJBANNR
- +22 WRITE !,LINE,!?PSJINDEN,"** "_PSJBANNR_" **",!,LINE,!!,"No Pharmacist Interventions to display",!!
- FOR KK=1:1:($GET(PSJIOSL)-10)
- WRITE !
- +23 DO HLD^PSGSICH
- End DoDot:1
- +24 IF $DATA(OUTARRAY)>1
- DO DSPINT(.OUTARRAY,$SELECT($GET(PSGORD):PSGORD,1:0))
- +25 SET PSJL=""
- WRITE !,PSJL
- +26 SET (PSJHISTF,PSJHISTO)=""
- FOR
- SET PSJHISTO=$ORDER(PSJOVRAR("B",PSJHISTO))
- if PSJHISTO=""!$GET(PSJHISTF)
- QUIT
- Begin DoDot:1
- +27 NEW PSJOCDT
- SET PSJOCDT=$GET(PSJOVRAR("B",PSJHISTO))
- if 'PSJOCDT
- QUIT
- if '$DATA(PSJOVRAR(PSGP,$GET(PSGORD),PSJOCDT,PSJHISTO))
- QUIT
- +28 IF PSJHISTO["I"
- SET PSJHISTF=1
- QUIT
- +29 IF PSJHISTF["C"
- KILL TMPOVR
- SET TMPOVR=""
- DO GETPROVR^PSGSICH1(PSGP,PSGORD,.TMPOVR,+PSJHISTO)
- SET PSJHISTF=$DATA(TMPOVR)>1
- KILL TMPOVR
- End DoDot:1
- +30 IF $GET(PSJHISTF)
- IF $$HISTHLD()
- DO FULL^VALM1
- WRITE @IOF
- DO OVRHIST(.PSJOVRAR,PSGORD)
- +31 KILL OUTARRAY,PSJOVRAR,PSJOCHIS,PSJDONED,PSJHIST
- +32 QUIT
- OVRHIST(PSJOAR,PSGORCD) ; History of overrides/interventions using hidden action
- +1 NEW PSJO1,PSJO2,PSJO3,PSJOERR,PSJOCHIS,FIRST,PSJIDT,PSJIOR,PSJIOSL
- SET PSJOCHIS=1
- SET FIRST=1
- SET PSJIOSL=$SELECT($GET(IOSL):IOSL,1:24)
- +2 SET PSJO1=""
- FOR
- SET PSJO1=$ORDER(PSJOAR(PSGP,PSGORCD,PSJO1),-1)
- if PSJO1=""
- QUIT
- Begin DoDot:1
- +3 SET PSJO2=""
- FOR
- SET PSJO2=$ORDER(PSJOAR(PSGP,PSGORCD,PSJO1,PSJO2),-1)
- if PSJO2=""
- QUIT
- Begin DoDot:2
- +4 ; This is the same as the 'current' provider override (multiple Inpatient orders can point to same CPRS order #)
- if '$DATA(PSJOAR("B",PSJO2))
- QUIT
- +5 KILL PSJTMPAR
- SET PSJTMPAR=""
- IF PSJO2["C"
- SET PSJO3=$GET(PSJOAR(PSGP,PSGORCD,PSJO1,PSJO2))
- IF PSJO3
- Begin DoDot:3
- +6 if '$DATA(PSJOAR("B",PSJO2))
- QUIT
- +7 DO GETPROVR^PSGSICH1(PSGP,PSJO3,.PSJTMPAR,PSJO2)
- IF $DATA(PSJTMPAR)>1
- DO DSPROVR^PSGSICH1(PSGP,PSJO3,.PSJTMPAR)
- +8 KILL PSJOAR("B",PSJO2)
- End DoDot:3
- QUIT
- +9 KILL PSJTMPAR
- SET PSJTMPAR=""
- IF PSJO2["I"
- SET PSJO3=$GET(PSJOAR(PSGP,PSGORCD,PSJO1,PSJO2))
- IF PSJO3
- Begin DoDot:3
- +10 if '$DATA(PSJOAR("B",PSJO2))
- QUIT
- +11 DO ONEINTER^PSGSICH(PSJO2,PSJO3,PSJO1,.PSJTMPAR)
- +12 IF $DATA(PSJTMPAR)>1
- DO FULL^VALM1
- WRITE @IOF
- DO DSPINT(.PSJTMPAR,PSJO3)
- +13 KILL PSJOAR("B",PSJO2)
- End DoDot:3
- QUIT
- End DoDot:2
- End DoDot:1
- +14 KILL PSJTMPAR,PSJOCHIS,PSJQUITD,PSJO1,PSJO2,PSJO3
- +15 QUIT
- HISTHLD() ;
- +1 KILL DIR
- SET DIR(0)="E"
- SET DIR("A")="View Historical Overrides/Interventions for this order (Y/N)"
- SET DIR("B")="Y"
- SET DIR(0)="Y"
- DO ^DIR
- +2 QUIT Y