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 Dec 13, 2024@02:03:15 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
