- 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 Feb 18, 2025@23:31:01 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