PSIVORC2 ;BIR/MLM - PROCESS INCOMPLETE IV ORDER - CONT ; Feb 02, 2022
;;5.0;INPATIENT MEDICATIONS;**29,49,50,65,58,85,101,110,127,151,181,267,275,257,281,313,346,355,319,399**;16 DEC 97;Build 64
;
; Reference to ^PS(51.2 is supported by DBIA #2178
; Reference to ^PS(55 is supported by DBIA #2191
; Reference to ^PS(52.6 is supported by DBIA #1231
; Reference to ^PS(52.7 is supported by DBIA #2173
; Reference to EN1^ORCFLAG is supported by DBIA #3620.
; Reference to ^PSSLOCK is supported by DBIA #2789
; Reference to ^TMP("PSODAOC",$J is supported by# DBIA 6071
;
EDCHK ;Update or create new order in 55.
D CKORD D:'$G(PSJIVORF) ORPARM^PSIVOREN I 'PSJIVORF W !,"Either the Inpatient Medications or the IV Medications package is not on, please check the Order Parameters file" Q
I PSIVCHG,PSJIVORF D NATURE^PSIVOREN I '$D(P("NAT")) W $C(7),"Order unchanged" Q
S:PSIVCHG P("21FLG")=""
I $G(PSJCOM) D IV^PSJCOMV Q
Q:$$NONVF()
ACTIVE ;
S PSJCOM=P("PRNTON")
I PSJCOM D VFYIV^PSJCOMV Q
S P("RES")=$P($G(^PS(53.1,+ON,0)),U,24)
I P("RES")="R" S P("NEWON")=P("OLDON") S PSJOSTOP="" D
.N PSJTROPI,PSJNVO S PSJNVO=$G(P("NEWON")) I (PSJNVO["P") D FILEOPI^PSJBCMA5(DFN,PSJNVO) S PSJTROPI=$$GETOPI^PSJBCMA5(DFN,PSJNVO) Q
.I ($G(P("PON"))["P"),($G(ON55)=P("PON")) S PSJNVO=P("PON") D FILEOPI^PSJBCMA5(DFN,PSJNVO) S PSJTROPI=$$GETOPI^PSJBCMA5(DFN,PSJNVO)
.I $G(P("NEWON")) D FILEOPI^PSJBCMA5(DFN,P("NEWON")) S PSJTROPI=$$GETOPI^PSJBCMA5(DFN,P("NEWON"))
.D RUPDATE^PSIVOREN(DFN,ON,P(2)) I $P($G(^PS(53.45,+$G(PSJSYSP),6,0)),"^",3)
I P("RES")'="R" S PSJORD=ON,P(17)="A",ORSTS=6,PSJORNP=P(6) D SETNEW^PSIVORFB S P("NEWON")=ON55 D @$S(PSIVCHG:"NEWORD",1:"OLDORD")
; copy activity log from Non-Verified order to Active order during Verify
I $G(PSJIOPIV) D MVOPI^PSJBCMA5($G(DFN),$G(PSJORD),$G(ON55)),MVOPIAL^PSJBCMA5($G(DFN),$G(PSJORD),$G(ON55)),CPINDLOG^PSIVINDL($G(DFN),$G(PSJORD),$G(ON55))
S (ON55,ON)=P("NEWON"),OD=P(2) D EN^PSIVORE
D CIMOI^PSJIMO1(DFN,ON55,"",$G(PSJORD))
D VF1^PSJLIACT("F","ORDER VERIFIED BY ",1)
D ENLBL^PSIVOPT(2,DUZ,DFN,3,+ON55,"N")
I $G(^PS(55,DFN,"IV",+ON55,4)) D EN1^PSJHL2(DFN,"ZV",ON55)
L -^PS(53.1,+$G(PSJORD)) L -^PS(55,DFN,"IV",+ON55)
Q
;
CKORD ;Check if new order is to be created.
I $G(PSIVCOPY) S PSIVCHG=0 Q
N ND,PSJCHG S PSIVCHG=0,ND(0)=$G(^PS(53.1,+ON,0)),ND("PD")=$G(^PS(53.1,+ON,.2))_U_$P(ND(0),U,3)
N X S X=$P($G(^PS(53.1,+ON,8)),U,5),X=$S(P(8)["@":$P(X,"@"),1:X)
S ND=$S($E(P("OT"))="I":P(8),1:X)_U_+$P(ND(0),U,3)_U_+$P(ND("PD"),U)
S ND=ND_U_$S($P(ND(0),U,2)=+P("CLRK"):+$P(ND(0),U,2),1:+P(6))
I ND'=($S($E(P("OT"))="I":P(8),P(8)["@":$P(P(8),"@"),1:P(8))_U_+P("MR")_U_+P("PD")_U_+P(6)) S PSIVCHG=1
I 'PSIVCHG I $P($G(^PS(53.1,+ON,2)),U)'=P(9) S:($G(P("DTYP"))'=1) PSIVDSFG=1 S PSIVCHG=1
N ND,TDRG,TMPDRG
Q:PSIVCHG
D TMPDRG1^PSJMISC(DFN,$G(ON),.TMPDRG)
I $$COMPARE^PSJMISC(.DRG,.TMPDRG,$S(P("DTYP")=1:0,1:1)) S PSIVCHG=1
K TMPDRG
Q:PSIVCHG
Q
CKPC ;
;PSJ*5*181 Note - No longer use by *181
;
Q:PSIVCHG I $E(P("OT"))'="I" D
.;
.; Check IV drugs for changes.
.S DNE=0 F DRGT="AD","SOL" I $D(DRG(DRGT)) S FIL="52."_$S(DRGT="AD":6,1:7) D
..N ND,TDRG,ON1 F DRGI=0:0 S DRGI=$O(DRG(DRGT,DRGI)) Q:'DRGI!DNE S TDRG(+$P(DRG(DRGT,DRGI),U),DRGI)=DRGI,TDRG("CNT")=+$G(TDRG("CNT"))+1
..F ON1=0:0 S ON1=$O(^PS(53.1,+ON,DRGT,ON1)) Q:'+ON1!DNE S ND=$G(^PS(53.1,+ON,DRGT,ON1,0)),ND("CNT")=$G(ND("CNT"))+1 D
...S DRG=+$P(ND,U) S:'$D(TDRG(+DRG)) (DNE,PSIVCHG)=1 F DRGI=0:0 S DRGI=$O(TDRG(+DRG,DRGI)) Q:'DRGI!DNE I $P($G(DRG(DRGT,DRGI)),U)_U_$P($G(DRG(DRGT,DRGI)),U,3)'=$P(ND,U,1,2) S (DNE,PSIVCHG)=1
..S:$G(ND("CNT"))'=$G(TDRG("CNT")) (DNE,PSIVCHG)=1 K ND,TDRG
Q
;
OLDORD ; Update old order, update order links.
Q:P("RES")="R"
S P("OLDON")=$P($G(^PS(53.1,+ON,0)),U,25) I P("OLDON")'=ON55 S $P(^PS(55,DFN,"IV",+ON55,2),U,8)=P("RES"),$P(^(2),U,5)=P("OLDON") I P("OLDON") D
.I P("OLDON")["V",$D(^PS(55,DFN,"IV",+P("OLDON"),0)) S $P(^(2),U,6)=ON55,$P(^(2),U,9)=P("RES")
.I P("OLDON")["A",$D(^PS(55,DFN,5,+P("OLDON"),0)) S $P(^(0),U,26,27)=ON55_U_P("RES")
.I $S(P("OLDON")["P":1,P("OLDON")["N":1,1:0),$D(^PS(53.1,+P("OLDON"),0)) S $P(^(0),U,26,27)=ON55_U_P("RES")
D PUT531^PSIVORFA S $P(^PS(53.1,+ON,0),U,25,26)="^",ON=ON55 D UPD100^PSIVORFA
Q
;
NEWORD ; Create new order, update order links.
Q:P("RES")="R"
S $P(^PS(53.1,+ON,0),U,26,27)=P("NEWON")_U_"E",PSIVAC="CE",PSJORNAT=P("NAT") D DC^PSIVORA
S P("NEWON")=$P($G(^PS(53.1,+PSJORD,0)),U,26),$P(^PS(55,DFN,"IV",+P("NEWON"),2),U,5)=PSJORD,$P(^(2),U,8)="E",ON=ON55
I PSJIVORF D EN1^PSJHL2(DFN,"SN",+ON55_"V","NEW ORDER CREATED")
Q
;
GTIVDRG ; Try to find an IV drug from the Orderable Item.
; If there is only 1 match to OI then stuff in DRG otherwise prompt user to select which
; ad/sol matched to OI
K PSIVOI N FIL,ND,SCR,PSJNOW
D NOW^%DTC S PSJNOW=%
S SCR("S")="S ND=$P($G(^(""I"")),U) I ND=""""!(ND>PSJNOW)"
F FIL=52.6,52.7 D FIND^DIC(FIL,,"@;.01;2"_$S(FIL=52.6:";19",1:""),"QXP",+P("PD"),,"AOI",SCR("S"),,"PSIVOI") I +PSIVOI("DILIST",0)>0 D Q
. S DRGT=$S(FIL=52.6:"AD",1:"SOL"),PSIVOI=DRGT
. I PSIVOI="AD" D
.. N XX,XXX,QC S XX=0 F S XX=$O(PSIVOI("DILIST",XX)) Q:XX="" S XXX=+PSIVOI("DILIST",XX,0) D LIST^DIC(52.61,","_XXX_",","@;.01;1;4","PQ",,,,,,,"PSIVQC") D
... I +$G(PSIVQC("DILIST",0))>0 S QC=0 F S QC=$O(PSIVQC("DILIST",QC)) Q:QC="" S PSIVOI("DILIST",XX,QC,0)=PSIVQC("DILIST",QC,0)
... K PSIVQC("DILIST",0),PSIVQC("DILIST",0,"MAP")
.. D RESET
. I +PSIVOI("DILIST",0)=1 D
.. S DRG=+PSIVOI("DILIST",1,0)
.. S DNE=1,DRG(DRGT,0)=1,ND=$G(^PS(FIL,+DRG,0)),DRG(DRGT,1)=+DRG_U_$P(ND,U)_U_$S(FIL=52.7:$P(ND,U,3),1:"")_U_U_$P(ND,U,13)_U_$P(ND,U,11)
K:+PSIVOI("DILIST",0)<2 PSIVOI
Q
;
EDIT ; Edit incomplete order
K PSIVENO
S PSIVAC="CE"
I $E(P("OT"))="I",'$D(DRG("AD")),('$D(DRG("SOL"))) D GTIVDRG
I P(4)="" D 53^PSIVORC1 Q:P(4)="" D ^PSIVORV2
D GSTRING^PSIVORE1,GTFLDS^PSIVORFE ;S (PSIVOK,EDIT)="57^58^59^3"_$S(P("DTYP")=1:"^26^39",1:"")_"^63^64^"_$S($E(P("OT"))="I":"101^109^",1:"")_"10^25"_$S(+P(6)'=+P("CLRK"):"^1",1:"") D GTFLDS^PSIVORFE
Q:$G(DONE)
I '$G(PSIVENO) S PSIVENO=1 D EN^VALM("PSJ LM IV AC/EDIT") S VALMBCK="Q"
Q
;
FINISH ; Ask only for missing data in incomplete IV order.
D GTDRG^PSIVORFA ; Re-setting DRG array
S P("OPI")=$$ENPC^PSJUTL("V",+PSIVUP,60,P("OPI")) I $E(P("OT"))="I",'$D(DRG("AD")),('$D(DRG("SOL"))) S DNE=0 D GTIVDRG
D:P(4)="" 53^PSIVORC1 Q:P(4)="" S P("DTYP")=$S(P(4)="":0,P(4)="P"!(P(23)="P")!(P(5)):1,P(4)="H":2,1:3)
I 'P(2) D ENT^PSIVCAL K %DT S X=P(2),%DT="RTX" D ^%DT S P(2)=+Y
I 'P(3) D ENSTOP^PSIVCAL K %DT S X=P(3),%DT="RTX" D ^%DT S P(3)=+Y
I 'P("MR") S P("MR")=$O(^PS(51.2,"B","INTRAVENOUS",0))_"^IV"
;
;Will prompt users to choose Dispense IV Additive when more than one are available for the Orderable Item
;
N PSJQUIT S PSJQUIT=0 D MULTADDS^PSJLIFN I $G(PSJQUIT) S VALMBCK="R" Q
;
S PSIVOK="1^3^10^25^26^39^57^58^59^63^64"
D CKFLDS^PSIVORC1 D:EDIT]"" EDIT^PSIVEDT G COMPLTE^PSIVORC1
Q
NONVF() ; Updated 53.1 status to non-verified after finish.
NEW PSGOEAV S PSGOEAV=+$P(PSJSYSP0,U,9)
S ^TMP("PSODAOC",$J,"IP NEW IEN")=ON
I +PSJSYSU=3,PSGOEAV Q 0
I +PSJSYSU=1,PSGOEAV Q 0
N INDCHNG S INDCHNG=$$DIFFIND^PSGOE42($G(DFN),PSJORD,P("IND")) ;*399-IND
I PSIVCHG D NWNONVF Q 1
S P(17)="N",P("REN")=0
D GTPD^PSIVORE2
N OLCLN,NWCLN
S OLCLN=$G(^PS(53.1,+ON,"DSS"))
W !,"...transcribing this non-verified order...."
S $P(^PS(53.1,+ON,.2),U)=""
D PUT531^PSIVORFA
I +INDCHNG=1 I PSJORD["P" D NEWNVAL^PSGAL5(PSJORD,6000,"INDICATION",$P(INDCHNG,U,2)) ;*399-IND
D NEWNVAL^PSGAL5(ON,$S(+PSJSYSU=1:22000,+PSJSYSU=3:22005,1:22006),"","")
I ($G(PSJINFIN)=2) D NEWNVAL^PSGAL5(ON,6000,"OTHER PRINT INFO")
; PSJ*319
S NWCLN=$G(^PS(53.1,+ON,"DSS"))
I $P(OLCLN,"^")'="",$P(OLCLN,"^")'=$P(NWCLN,"^") D NEWNVAL^PSGAL5(+ON,6000,"CLINIC",$P($G(^SC(+$P(OLCLN,"^"),0)),"^"))
I $P(OLCLN,"^",2)'="",$P(OLCLN,"^",2)'=$P(NWCLN,"^",2) D NEWNVAL^PSGAL5(+ON,6000,"APPOINTMENT DATE/TIME",$P(OLCLN,"^",2))
NEW PSIVORFA S PSIVORFA=1 D:ON["V" DEL55^PSIVORE2
D VF
Q 1
NWNONVF ;Create non-verified due to edit
K DA D ENGNN^PSGOETO S P("NEWON")=DA_"P",P(17)="N",P("REN")=0
I $D(^PS(53.45,PSJSYSP,6,1)) D FILEOPI^PSJBCMA5(DFN,P("NEWON"))
S PSJORD=ON,$P(^PS(53.1,+ON,0),U,26,27)=P("NEWON")_U_"E",PSIVAC="CE",PSJORNAT=P("NAT") D DC^PSIVORA
S P("OLDON")=ON,ON=P("NEWON")
I $D(^PS(53.1,+P("OLDON"),12)) M ^PS(53.1,+P("NEWON"),12)=^PS(53.1,+P("OLDON"),12)
S P("RES")="E"
S P("DO")="" D GTPD^PSIVORE2 ;Get dosage order if not defined for IPM IV
D PUT531^PSIVORFA
I +INDCHNG=1 I PSJORD["P" D NEWNVAL^PSGAL5(ON,6000,"INDICATION",$P(INDCHNG,U,2)) ;*399-IND
S $P(^PS(53.1,+ON,0),U,25,26)=P("OLDON")_U_""
D NEWNVAL^PSGAL5(ON,$S(+PSJSYSU=1:22000,+PSJSYSU=3:22005,1:22006),"","")
D EN1^PSJHL2(DFN,"SN",ON,"SEND ORDER NUMBER")
S ^TMP("PSODAOC",$J,"IP NEW IEN")=ON
S:$D(PSGP)#10 PSJNOL=$$LS^PSSLOCK(PSGP,ON)
D VF
Q
VF ; Display Verify screen
Q:ON'["P"
K PSJIVBD
D GT531^PSIVORFA(DFN,ON)
S:$G(ON)]"" (ON55,PSJORD)=ON ;* CCR 6700
S PSGACT="EL"
I P(17)="N",(P("OLDON")=""),(+P("CLRK")=DUZ) S PSGACT="ELD"
;I +PSJSYSU=3!(+PSJSYSU=1) S PSGACT="DELV"
I +PSJSYSU=3 S PSGACT="DELV"
I +PSJSYSU=1 S PSGACT="DEL" I $$FNP^PSGOE1(+ON) S PSGACT=PSGACT_"V" ;p319
I +PSJSYSU=3,$L($T(EN1^ORCFLAG)) S PSGACT=PSGACT_"G"
I P("OT")="I" S PSJSTAR="(1)^(5)^(7)^(9)^(10)"
I P("OT")'="I" S PSJSTAR="(1)^(2)^(3)^(5)^(7)^(9)"
I '$G(PSJEDFLG) D
.D EN^VALM("PSJ LM IV INPT ACTIVE")
K PSJEDFLG
; Only store allergy if not verified after entering the order
I ($G(ON)["P"),($S(($G(PSJOCFG)="NEW OE IV"):1,($G(PSJOCFG)="FN IV"):1,$G(PSIVENO):1,1:0)) D SETOC^PSJNEWOC(ON)
Q
;
RESET ;Reset PSIVOI("DILIST") for additives with quick codes
N XX,XXX,CNT S CNT=0
S XX=0 F S XX=$O(PSIVOI("DILIST",XX)) Q:XX="" S CNT=CNT+1,LYN(CNT)=PSIVOI("DILIST",XX,0) D
. S XXX=0 F S XXX=$O(PSIVOI("DILIST",XX,XXX)) Q:XXX="" D
.. S CNT=CNT+1,LYN(CNT)=$P(PSIVOI("DILIST",XX,0),"^")_"^"_$P(PSIVOI("DILIST",XX,XXX,0),"^",2)_"^"_$P(PSIVOI("DILIST",XX,XXX,0),"^")_"^"_"QC"_"^"_$P(PSIVOI("DILIST",XX,XXX,0),"^",3)_"^"_$P(PSIVOI("DILIST",XX,XXX,0),"^",4)
K PSIVOI("DILIST")
S PSIVOI("DILIST",0)=CNT_"^*^0^"
S XX=0 F S XX=$O(LYN(XX)) Q:'XX S PSIVOI("DILIST",XX,0)=LYN(XX)
K LYN
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSIVORC2 10349 printed Oct 16, 2024@18:05:24 Page 2
PSIVORC2 ;BIR/MLM - PROCESS INCOMPLETE IV ORDER - CONT ; Feb 02, 2022
+1 ;;5.0;INPATIENT MEDICATIONS;**29,49,50,65,58,85,101,110,127,151,181,267,275,257,281,313,346,355,319,399**;16 DEC 97;Build 64
+2 ;
+3 ; Reference to ^PS(51.2 is supported by DBIA #2178
+4 ; Reference to ^PS(55 is supported by DBIA #2191
+5 ; Reference to ^PS(52.6 is supported by DBIA #1231
+6 ; Reference to ^PS(52.7 is supported by DBIA #2173
+7 ; Reference to EN1^ORCFLAG is supported by DBIA #3620.
+8 ; Reference to ^PSSLOCK is supported by DBIA #2789
+9 ; Reference to ^TMP("PSODAOC",$J is supported by# DBIA 6071
+10 ;
EDCHK ;Update or create new order in 55.
+1 DO CKORD
if '$GET(PSJIVORF)
DO ORPARM^PSIVOREN
IF 'PSJIVORF
WRITE !,"Either the Inpatient Medications or the IV Medications package is not on, please check the Order Parameters file"
QUIT
+2 IF PSIVCHG
IF PSJIVORF
DO NATURE^PSIVOREN
IF '$DATA(P("NAT"))
WRITE $CHAR(7),"Order unchanged"
QUIT
+3 if PSIVCHG
SET P("21FLG")=""
+4 IF $GET(PSJCOM)
DO IV^PSJCOMV
QUIT
+5 if $$NONVF()
QUIT
ACTIVE ;
+1 SET PSJCOM=P("PRNTON")
+2 IF PSJCOM
DO VFYIV^PSJCOMV
QUIT
+3 SET P("RES")=$PIECE($GET(^PS(53.1,+ON,0)),U,24)
+4 IF P("RES")="R"
SET P("NEWON")=P("OLDON")
SET PSJOSTOP=""
Begin DoDot:1
+5 NEW PSJTROPI,PSJNVO
SET PSJNVO=$GET(P("NEWON"))
IF (PSJNVO["P")
DO FILEOPI^PSJBCMA5(DFN,PSJNVO)
SET PSJTROPI=$$GETOPI^PSJBCMA5(DFN,PSJNVO)
QUIT
+6 IF ($GET(P("PON"))["P")
IF ($GET(ON55)=P("PON"))
SET PSJNVO=P("PON")
DO FILEOPI^PSJBCMA5(DFN,PSJNVO)
SET PSJTROPI=$$GETOPI^PSJBCMA5(DFN,PSJNVO)
+7 IF $GET(P("NEWON"))
DO FILEOPI^PSJBCMA5(DFN,P("NEWON"))
SET PSJTROPI=$$GETOPI^PSJBCMA5(DFN,P("NEWON"))
+8 DO RUPDATE^PSIVOREN(DFN,ON,P(2))
IF $PIECE($GET(^PS(53.45,+$GET(PSJSYSP),6,0)),"^",3)
End DoDot:1
+9 IF P("RES")'="R"
SET PSJORD=ON
SET P(17)="A"
SET ORSTS=6
SET PSJORNP=P(6)
DO SETNEW^PSIVORFB
SET P("NEWON")=ON55
DO @$SELECT(PSIVCHG:"NEWORD",1:"OLDORD")
+10 ; copy activity log from Non-Verified order to Active order during Verify
+11 IF $GET(PSJIOPIV)
DO MVOPI^PSJBCMA5($GET(DFN),$GET(PSJORD),$GET(ON55))
DO MVOPIAL^PSJBCMA5($GET(DFN),$GET(PSJORD),$GET(ON55))
DO CPINDLOG^PSIVINDL($GET(DFN),$GET(PSJORD),$GET(ON55))
+12 SET (ON55,ON)=P("NEWON")
SET OD=P(2)
DO EN^PSIVORE
+13 DO CIMOI^PSJIMO1(DFN,ON55,"",$GET(PSJORD))
+14 DO VF1^PSJLIACT("F","ORDER VERIFIED BY ",1)
+15 DO ENLBL^PSIVOPT(2,DUZ,DFN,3,+ON55,"N")
+16 IF $GET(^PS(55,DFN,"IV",+ON55,4))
DO EN1^PSJHL2(DFN,"ZV",ON55)
+17 LOCK -^PS(53.1,+$GET(PSJORD))
LOCK -^PS(55,DFN,"IV",+ON55)
+18 QUIT
+19 ;
CKORD ;Check if new order is to be created.
+1 IF $GET(PSIVCOPY)
SET PSIVCHG=0
QUIT
+2 NEW ND,PSJCHG
SET PSIVCHG=0
SET ND(0)=$GET(^PS(53.1,+ON,0))
SET ND("PD")=$GET(^PS(53.1,+ON,.2))_U_$PIECE(ND(0),U,3)
+3 NEW X
SET X=$PIECE($GET(^PS(53.1,+ON,8)),U,5)
SET X=$SELECT(P(8)["@":$PIECE(X,"@"),1:X)
+4 SET ND=$SELECT($EXTRACT(P("OT"))="I":P(8),1:X)_U_+$PIECE(ND(0),U,3)_U_+$PIECE(ND("PD"),U)
+5 SET ND=ND_U_$SELECT($PIECE(ND(0),U,2)=+P("CLRK"):+$PIECE(ND(0),U,2),1:+P(6))
+6 IF ND'=($SELECT($EXTRACT(P("OT"))="I":P(8),P(8)["@":$PIECE(P(8),"@"),1:P(8))_U_+P("MR")_U_+P("PD")_U_+P(6))
SET PSIVCHG=1
+7 IF 'PSIVCHG
IF $PIECE($GET(^PS(53.1,+ON,2)),U)'=P(9)
if ($GET(P("DTYP"))'=1)
SET PSIVDSFG=1
SET PSIVCHG=1
+8 NEW ND,TDRG,TMPDRG
+9 if PSIVCHG
QUIT
+10 DO TMPDRG1^PSJMISC(DFN,$GET(ON),.TMPDRG)
+11 IF $$COMPARE^PSJMISC(.DRG,.TMPDRG,$SELECT(P("DTYP")=1:0,1:1))
SET PSIVCHG=1
+12 KILL TMPDRG
+13 if PSIVCHG
QUIT
+14 QUIT
CKPC ;
+1 ;PSJ*5*181 Note - No longer use by *181
+2 ;
+3 if PSIVCHG
QUIT
IF $EXTRACT(P("OT"))'="I"
Begin DoDot:1
+4 ;
+5 ; Check IV drugs for changes.
+6 SET DNE=0
FOR DRGT="AD","SOL"
IF $DATA(DRG(DRGT))
SET FIL="52."_$SELECT(DRGT="AD":6,1:7)
Begin DoDot:2
+7 NEW ND,TDRG,ON1
FOR DRGI=0:0
SET DRGI=$ORDER(DRG(DRGT,DRGI))
if 'DRGI!DNE
QUIT
SET TDRG(+$PIECE(DRG(DRGT,DRGI),U),DRGI)=DRGI
SET TDRG("CNT")=+$GET(TDRG("CNT"))+1
+8 FOR ON1=0:0
SET ON1=$ORDER(^PS(53.1,+ON,DRGT,ON1))
if '+ON1!DNE
QUIT
SET ND=$GET(^PS(53.1,+ON,DRGT,ON1,0))
SET ND("CNT")=$GET(ND("CNT"))+1
Begin DoDot:3
+9 SET DRG=+$PIECE(ND,U)
if '$DATA(TDRG(+DRG))
SET (DNE,PSIVCHG)=1
FOR DRGI=0:0
SET DRGI=$ORDER(TDRG(+DRG,DRGI))
if 'DRGI!DNE
QUIT
IF $PIECE($GET(DRG(DRGT,DRGI)),U)_U_$PIECE($GET(DRG(DRGT,DRGI)),U,3)'=$PIECE(ND,U,1,2)
SET (DNE,PSIVCHG)=1
End DoDot:3
+10 if $GET(ND("CNT"))'=$GET(TDRG("CNT"))
SET (DNE,PSIVCHG)=1
KILL ND,TDRG
End DoDot:2
End DoDot:1
+11 QUIT
+12 ;
OLDORD ; Update old order, update order links.
+1 if P("RES")="R"
QUIT
+2 SET P("OLDON")=$PIECE($GET(^PS(53.1,+ON,0)),U,25)
IF P("OLDON")'=ON55
SET $PIECE(^PS(55,DFN,"IV",+ON55,2),U,8)=P("RES")
SET $PIECE(^(2),U,5)=P("OLDON")
IF P("OLDON")
Begin DoDot:1
+3 IF P("OLDON")["V"
IF $DATA(^PS(55,DFN,"IV",+P("OLDON"),0))
SET $PIECE(^(2),U,6)=ON55
SET $PIECE(^(2),U,9)=P("RES")
+4 IF P("OLDON")["A"
IF $DATA(^PS(55,DFN,5,+P("OLDON"),0))
SET $PIECE(^(0),U,26,27)=ON55_U_P("RES")
+5 IF $SELECT(P("OLDON")["P":1,P("OLDON")["N":1,1:0)
IF $DATA(^PS(53.1,+P("OLDON"),0))
SET $PIECE(^(0),U,26,27)=ON55_U_P("RES")
End DoDot:1
+6 DO PUT531^PSIVORFA
SET $PIECE(^PS(53.1,+ON,0),U,25,26)="^"
SET ON=ON55
DO UPD100^PSIVORFA
+7 QUIT
+8 ;
NEWORD ; Create new order, update order links.
+1 if P("RES")="R"
QUIT
+2 SET $PIECE(^PS(53.1,+ON,0),U,26,27)=P("NEWON")_U_"E"
SET PSIVAC="CE"
SET PSJORNAT=P("NAT")
DO DC^PSIVORA
+3 SET P("NEWON")=$PIECE($GET(^PS(53.1,+PSJORD,0)),U,26)
SET $PIECE(^PS(55,DFN,"IV",+P("NEWON"),2),U,5)=PSJORD
SET $PIECE(^(2),U,8)="E"
SET ON=ON55
+4 IF PSJIVORF
DO EN1^PSJHL2(DFN,"SN",+ON55_"V","NEW ORDER CREATED")
+5 QUIT
+6 ;
GTIVDRG ; Try to find an IV drug from the Orderable Item.
+1 ; If there is only 1 match to OI then stuff in DRG otherwise prompt user to select which
+2 ; ad/sol matched to OI
+3 KILL PSIVOI
NEW FIL,ND,SCR,PSJNOW
+4 DO NOW^%DTC
SET PSJNOW=%
+5 SET SCR("S")="S ND=$P($G(^(""I"")),U) I ND=""""!(ND>PSJNOW)"
+6 FOR FIL=52.6,52.7
DO FIND^DIC(FIL,,"@;.01;2"_$SELECT(FIL=52.6:";19",1:""),"QXP",+P("PD"),,"AOI",SCR("S"),,"PSIVOI")
IF +PSIVOI("DILIST",0)>0
Begin DoDot:1
+7 SET DRGT=$SELECT(FIL=52.6:"AD",1:"SOL")
SET PSIVOI=DRGT
+8 IF PSIVOI="AD"
Begin DoDot:2
+9 NEW XX,XXX,QC
SET XX=0
FOR
SET XX=$ORDER(PSIVOI("DILIST",XX))
if XX=""
QUIT
SET XXX=+PSIVOI("DILIST",XX,0)
DO LIST^DIC(52.61,","_XXX_",","@;.01;1;4","PQ",,,,,,,"PSIVQC")
Begin DoDot:3
+10 IF +$GET(PSIVQC("DILIST",0))>0
SET QC=0
FOR
SET QC=$ORDER(PSIVQC("DILIST",QC))
if QC=""
QUIT
SET PSIVOI("DILIST",XX,QC,0)=PSIVQC("DILIST",QC,0)
+11 KILL PSIVQC("DILIST",0),PSIVQC("DILIST",0,"MAP")
End DoDot:3
+12 DO RESET
End DoDot:2
+13 IF +PSIVOI("DILIST",0)=1
Begin DoDot:2
+14 SET DRG=+PSIVOI("DILIST",1,0)
+15 SET DNE=1
SET DRG(DRGT,0)=1
SET ND=$GET(^PS(FIL,+DRG,0))
SET DRG(DRGT,1)=+DRG_U_$PIECE(ND,U)_U_$SELECT(FIL=52.7:$PIECE(ND,U,3),1:"")_U_U_$PIECE(ND,U,13)_U_$PIECE(ND,U,11)
End DoDot:2
End DoDot:1
QUIT
+16 if +PSIVOI("DILIST",0)<2
KILL PSIVOI
+17 QUIT
+18 ;
EDIT ; Edit incomplete order
+1 KILL PSIVENO
+2 SET PSIVAC="CE"
+3 IF $EXTRACT(P("OT"))="I"
IF '$DATA(DRG("AD"))
IF ('$DATA(DRG("SOL")))
DO GTIVDRG
+4 IF P(4)=""
DO 53^PSIVORC1
if P(4)=""
QUIT
DO ^PSIVORV2
+5 ;S (PSIVOK,EDIT)="57^58^59^3"_$S(P("DTYP")=1:"^26^39",1:"")_"^63^64^"_$S($E(P("OT"))="I":"101^109^",1:"")_"10^25"_$S(+P(6)'=+P("CLRK"):"^1",1:"") D GTFLDS^PSIVORFE
DO GSTRING^PSIVORE1
DO GTFLDS^PSIVORFE
+6 if $GET(DONE)
QUIT
+7 IF '$GET(PSIVENO)
SET PSIVENO=1
DO EN^VALM("PSJ LM IV AC/EDIT")
SET VALMBCK="Q"
+8 QUIT
+9 ;
FINISH ; Ask only for missing data in incomplete IV order.
+1 ; Re-setting DRG array
DO GTDRG^PSIVORFA
+2 SET P("OPI")=$$ENPC^PSJUTL("V",+PSIVUP,60,P("OPI"))
IF $EXTRACT(P("OT"))="I"
IF '$DATA(DRG("AD"))
IF ('$DATA(DRG("SOL")))
SET DNE=0
DO GTIVDRG
+3 if P(4)=""
DO 53^PSIVORC1
if P(4)=""
QUIT
SET P("DTYP")=$SELECT(P(4)="":0,P(4)="P"!(P(23)="P")!(P(5)):1,P(4)="H":2,1:3)
+4 IF 'P(2)
DO ENT^PSIVCAL
KILL %DT
SET X=P(2)
SET %DT="RTX"
DO ^%DT
SET P(2)=+Y
+5 IF 'P(3)
DO ENSTOP^PSIVCAL
KILL %DT
SET X=P(3)
SET %DT="RTX"
DO ^%DT
SET P(3)=+Y
+6 IF 'P("MR")
SET P("MR")=$ORDER(^PS(51.2,"B","INTRAVENOUS",0))_"^IV"
+7 ;
+8 ;Will prompt users to choose Dispense IV Additive when more than one are available for the Orderable Item
+9 ;
+10 NEW PSJQUIT
SET PSJQUIT=0
DO MULTADDS^PSJLIFN
IF $GET(PSJQUIT)
SET VALMBCK="R"
QUIT
+11 ;
+12 SET PSIVOK="1^3^10^25^26^39^57^58^59^63^64"
+13 DO CKFLDS^PSIVORC1
if EDIT]""
DO EDIT^PSIVEDT
GOTO COMPLTE^PSIVORC1
+14 QUIT
NONVF() ; Updated 53.1 status to non-verified after finish.
+1 NEW PSGOEAV
SET PSGOEAV=+$PIECE(PSJSYSP0,U,9)
+2 SET ^TMP("PSODAOC",$JOB,"IP NEW IEN")=ON
+3 IF +PSJSYSU=3
IF PSGOEAV
QUIT 0
+4 IF +PSJSYSU=1
IF PSGOEAV
QUIT 0
+5 ;*399-IND
NEW INDCHNG
SET INDCHNG=$$DIFFIND^PSGOE42($GET(DFN),PSJORD,P("IND"))
+6 IF PSIVCHG
DO NWNONVF
QUIT 1
+7 SET P(17)="N"
SET P("REN")=0
+8 DO GTPD^PSIVORE2
+9 NEW OLCLN,NWCLN
+10 SET OLCLN=$GET(^PS(53.1,+ON,"DSS"))
+11 WRITE !,"...transcribing this non-verified order...."
+12 SET $PIECE(^PS(53.1,+ON,.2),U)=""
+13 DO PUT531^PSIVORFA
+14 ;*399-IND
IF +INDCHNG=1
IF PSJORD["P"
DO NEWNVAL^PSGAL5(PSJORD,6000,"INDICATION",$PIECE(INDCHNG,U,2))
+15 DO NEWNVAL^PSGAL5(ON,$SELECT(+PSJSYSU=1:22000,+PSJSYSU=3:22005,1:22006),"","")
+16 IF ($GET(PSJINFIN)=2)
DO NEWNVAL^PSGAL5(ON,6000,"OTHER PRINT INFO")
+17 ; PSJ*319
+18 SET NWCLN=$GET(^PS(53.1,+ON,"DSS"))
+19 IF $PIECE(OLCLN,"^")'=""
IF $PIECE(OLCLN,"^")'=$PIECE(NWCLN,"^")
DO NEWNVAL^PSGAL5(+ON,6000,"CLINIC",$PIECE($GET(^SC(+$PIECE(OLCLN,"^"),0)),"^"))
+20 IF $PIECE(OLCLN,"^",2)'=""
IF $PIECE(OLCLN,"^",2)'=$PIECE(NWCLN,"^",2)
DO NEWNVAL^PSGAL5(+ON,6000,"APPOINTMENT DATE/TIME",$PIECE(OLCLN,"^",2))
+21 NEW PSIVORFA
SET PSIVORFA=1
if ON["V"
DO DEL55^PSIVORE2
+22 DO VF
+23 QUIT 1
NWNONVF ;Create non-verified due to edit
+1 KILL DA
DO ENGNN^PSGOETO
SET P("NEWON")=DA_"P"
SET P(17)="N"
SET P("REN")=0
+2 IF $DATA(^PS(53.45,PSJSYSP,6,1))
DO FILEOPI^PSJBCMA5(DFN,P("NEWON"))
+3 SET PSJORD=ON
SET $PIECE(^PS(53.1,+ON,0),U,26,27)=P("NEWON")_U_"E"
SET PSIVAC="CE"
SET PSJORNAT=P("NAT")
DO DC^PSIVORA
+4 SET P("OLDON")=ON
SET ON=P("NEWON")
+5 IF $DATA(^PS(53.1,+P("OLDON"),12))
MERGE ^PS(53.1,+P("NEWON"),12)=^PS(53.1,+P("OLDON"),12)
+6 SET P("RES")="E"
+7 ;Get dosage order if not defined for IPM IV
SET P("DO")=""
DO GTPD^PSIVORE2
+8 DO PUT531^PSIVORFA
+9 ;*399-IND
IF +INDCHNG=1
IF PSJORD["P"
DO NEWNVAL^PSGAL5(ON,6000,"INDICATION",$PIECE(INDCHNG,U,2))
+10 SET $PIECE(^PS(53.1,+ON,0),U,25,26)=P("OLDON")_U_""
+11 DO NEWNVAL^PSGAL5(ON,$SELECT(+PSJSYSU=1:22000,+PSJSYSU=3:22005,1:22006),"","")
+12 DO EN1^PSJHL2(DFN,"SN",ON,"SEND ORDER NUMBER")
+13 SET ^TMP("PSODAOC",$JOB,"IP NEW IEN")=ON
+14 if $DATA(PSGP)#10
SET PSJNOL=$$LS^PSSLOCK(PSGP,ON)
+15 DO VF
+16 QUIT
VF ; Display Verify screen
+1 if ON'["P"
QUIT
+2 KILL PSJIVBD
+3 DO GT531^PSIVORFA(DFN,ON)
+4 ;* CCR 6700
if $GET(ON)]""
SET (ON55,PSJORD)=ON
+5 SET PSGACT="EL"
+6 IF P(17)="N"
IF (P("OLDON")="")
IF (+P("CLRK")=DUZ)
SET PSGACT="ELD"
+7 ;I +PSJSYSU=3!(+PSJSYSU=1) S PSGACT="DELV"
+8 IF +PSJSYSU=3
SET PSGACT="DELV"
+9 ;p319
IF +PSJSYSU=1
SET PSGACT="DEL"
IF $$FNP^PSGOE1(+ON)
SET PSGACT=PSGACT_"V"
+10 IF +PSJSYSU=3
IF $LENGTH($TEXT(EN1^ORCFLAG))
SET PSGACT=PSGACT_"G"
+11 IF P("OT")="I"
SET PSJSTAR="(1)^(5)^(7)^(9)^(10)"
+12 IF P("OT")'="I"
SET PSJSTAR="(1)^(2)^(3)^(5)^(7)^(9)"
+13 IF '$GET(PSJEDFLG)
Begin DoDot:1
+14 DO EN^VALM("PSJ LM IV INPT ACTIVE")
End DoDot:1
+15 KILL PSJEDFLG
+16 ; Only store allergy if not verified after entering the order
+17 IF ($GET(ON)["P")
IF ($SELECT(($GET(PSJOCFG)="NEW OE IV"):1,($GET(PSJOCFG)="FN IV"):1,$GET(PSIVENO):1,1:0))
DO SETOC^PSJNEWOC(ON)
+18 QUIT
+19 ;
RESET ;Reset PSIVOI("DILIST") for additives with quick codes
+1 NEW XX,XXX,CNT
SET CNT=0
+2 SET XX=0
FOR
SET XX=$ORDER(PSIVOI("DILIST",XX))
if XX=""
QUIT
SET CNT=CNT+1
SET LYN(CNT)=PSIVOI("DILIST",XX,0)
Begin DoDot:1
+3 SET XXX=0
FOR
SET XXX=$ORDER(PSIVOI("DILIST",XX,XXX))
if XXX=""
QUIT
Begin DoDot:2
+4 SET CNT=CNT+1
SET LYN(CNT)=$PIECE(PSIVOI("DILIST",XX,0),"^")_"^"_$PIECE(PSIVOI("DILIST",XX,XXX,0),"^",2)_"^"_$PIECE(PSIVOI("DILIST",XX,XXX,0),"^")_"^"_"QC"_"^"_$PIECE(PSIVOI("DILIST",XX,XXX,0),"^",3)_"^"_$PIECE(PSIVOI("DILIST",XX,XXX,0),"^",4
)
End DoDot:2
End DoDot:1
+5 KILL PSIVOI("DILIST")
+6 SET PSIVOI("DILIST",0)=CNT_"^*^0^"
+7 SET XX=0
FOR
SET XX=$ORDER(LYN(XX))
if 'XX
QUIT
SET PSIVOI("DILIST",XX,0)=LYN(XX)
+8 KILL LYN
+9 QUIT
