- PSJHL10 ;BIR/LDT,BSJ-VALIDATE INCOMING HL7 DATA/CREATE NEW ORDER ;30 MAY 07
- ;;5.0;INPATIENT MEDICATIONS;**58,78,91,109,110,195,257,307**;16 DEC 97;Build 18
- ;
- ; Reference to ^PSDRUG is supported by DBIA# 2192.
- ; 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 ^PSBAPIPM is supported by DBIA# 3564.
- ; Reference to ^ORERR is supported by DBIA# 2187.
- ;
- VALID ;
- ;Call BCMA for rest of data
- D MOB^PSBAPIPM(PSJHLDFN,+PSJORDER)
- N DATA0,CHK S DATA0=$G(^TMP("PSB",$J,0)) I DATA0=-1 S PSREASON="""YOUR ORDER WAS NOT SAVED. EXIT BCMA, SIGN BACK IN, THEN TRY AGAIN.""" D ERROR Q
- I $P(DATA0,"^")'=PSJHLDFN S PSREASON="Patient does not match" D ERROR Q
- I $P(DATA0,"^",2)'=+PSJORDER S PSREASON="Order number does not match" D ERROR Q
- N VAIP S DFN=PSJHLDFN,VAIP("D")=$G(LOGIN) D IN5^VADPT
- ;If UD do UD set/validate.
- I $P(DATA0,"^",3)="" D UDSET
- ;If IV do IV set/validate.
- I $P(DATA0,"^",3)]"" D IVSET
- D:'CHK EN1^PSJHL2(PSJHLDFN,"OK",PSGORD),EN1^PSJHL2(PSJHLDFN,"SC",PSGORD),EN1^PSJHL2(PSJHLDFN,"ZV",PSGORD),MOBR^PSBAPIPM(PSJHLDFN,+PSJORDER,PSGORD)
- Q
- ;
- ERROR ;Sends error msg to CPRS, logs error in OE/RR Errors file
- S X="ORERR" X ^%ZOSF("TEST") I D EN^ORERR(PSREASON,.PSJMSG),MOBR^PSBAPIPM(PSJHLDFN,+PSJORDER)
- D EN1^PSJHLERR(PSJHLDFN,"OC",PSJORDER,PSREASON) S QFLG=1 K ^TMP("PSJNVO",$J),^TMP("PSB",$J)
- Q
- ;
- UDSET ;Set up UD variables
- N PSGPR,PSGMR,PSGSM,PSGHSM,PSGST,PSGP,PSGSCH,PSGPDRG,PSGDO,PSGNESD,PSGNEFD,PSGOEAV,PSJSYSU,PSGS0XT,PSGS0Y
- S PSGPR=PROVIDER,PSGMR=ROUTE,PSGSM=0,PSGHSM="",PSGST="O",PSGP=PSJHLDFN,PSGSCH=SCHEDULE,PSGPDRG=PSITEM
- S (PSGNESD,PSGNEFD)=+$P(DATA0,"^",5),PSGOEAV=1,PSJSYSU=1,PSGS0XT="O",PSGS0Y=""
- I $G(DOSE)]"",$G(UNIT)]"" S PSGDO=DOSE_UNIT
- I $G(PSGDO)']"",$G(INSTR)]"" S PSGDO=$$TRIM^XLFSTR(INSTR,"R"," ")
- S CHK=""
- S ND=U_PSGPR_U_PSGMR_"^U^"_PSGSM_U_PSGHSM_U_PSGST_"^^"_"E"_"^^^^^"_LOGIN_U_PSGP_U_LOGIN
- D CHK("^^"_PSGMR_"^^^^"_PSGST,PSGPDRG_U_PSGDO,PSGSCH_U_PSGNESD_"^^"_PSGNEFD)
- I CHK D ERROR Q
- I PSGSCH'="STAT",PSGSCH'="NOW" S PSREASON="Invalid Schedule" S CHK=1 D ERROR Q
- I $D(^XUSEC("ORELSE",DUZ)),ORDCON'="V",ORDCON'="P" S PSREASON="Invalid Nature of Order" S CHK=1 D ERROR Q
- D:'$D(^PS(55,PSGP,0)) ENSET0^PSGNE3(PSGP) S $P(^PS(55,PSGP,5.1),U,2)=PSGPR,PSGOEPR=PSGPR
- S ND0=ND D ENGNA^PSGOETO
- I $D(^PS(51.2,+PSGMR,0)),$P(^(0),U,3)]"" S PSGMRN=$P(^(0),U,3)
- S ND0=DA_ND0
- S $P(ND0,"^",21)=PSJORDER
- S ND2=PSGSCH_U_PSGNESD_"^^"_PSGNEFD_U_PSGS0Y_U_PSGS0XT_"^^^^"_+VAIP(5)
- S $P(ND4,U,7)=DUZ I PSGOEAV,PSJSYSU D
- .S $P(ND4,U,PSJSYSU,PSJSYSU+1)=DUZ_U_+$P(DATA0,"^",5),$P(ND4,U,+PSJSYSU=1+9)=1,$P(ND4,U,+PSJSYSU=3+9)=0
- .S $P(ND4,U,9,10)=+$P(ND4,U,9)_U_+$P(ND4,U,10)
- .I '$P(ND4,U,9) S ^PS(55,"APV",PSGP,DA)=""
- .I '$P(ND4,U,10) S ^PS(55,"NPV",PSGP,DA)=""
- .I $P(ND4,U,9) K ^PS(55,"APV",PSGP,DA)
- .I $P(ND4,U,10) K ^PS(55,"NPV",PSGP,DA)
- S F="^PS(55,"_PSGP_",5,"_DA_",",@(F_"0)")=ND0
- ;naked reference on the four (4) lines below refer to the full ref to ^PS(55,PSGP,5,DA created by indirection using variable F
- I $G(INSTR)]"" S @(F_".3)")=INSTR
- S @(F_".2)")=PSGPDRG_U_PSGDO S $P(^(.2),U,3,6)=$G(ORDCON)_"^"_$E(PRIORITY,2)_"^"_$G(DOSE)_"^"_$G(UNIT)
- S @(F_"2)")=ND2,^(4)=ND4
- S (C,X)=0 F S X=$O(^TMP("PSB",$J,700,X)) Q:'X S D=$G(^(X,0)) I D S C=C+1,@(F_"1,"_C_",0)")=$P(D,U,1,2),@(F_"1,""B"","_+D_","_C_")")=""
- S:C @(F_"1,0)")=U_"55.07P^"_C_U_C
- I $D(PROCOM) D
- .;naked refs on the four lines below refer to the full ref to ^PS(55,PSGP,5,DA created by indrection using variable F
- .I '$D(@(F_"12,0)")) S ^(0)=U_55.0612_U_0_U_0
- .S JJ=0 F S JJ=$O(PROCOM(JJ)) Q:'JJ S $P(@(F_"12,0)"),"^",3,4)=JJ_"^"_JJ,@(F_"12,"_JJ_",0)")=PROCOM(JJ)
- S @(F_"6)")=$$ENPC^PSJHL11("U",180)
- I $G(APPT)]"" S @(F_"8)")=LOC_"^"_APPT
- D CIMOU^PSJIMO1(PSGP,DA)
- D CRA^PSGOETO
- L -^PS(55,DFN,5,DA)
- S PSGORD=DA_"U"
- OUT ;
- Q
- ;
- CHK(X,Y,Z) ;Check for required fields
- ; Input: X="^^"_MED ROUTE_"^^^^"_SCH TYPE
- ; Y=ORDERABLE ITEM_"^"_DOSAGE ORDERED
- ; Z=SCHEDULE_"^"_START DATE/TIME_"^^"_STOP DATE/TIME
- D CHK^PSJHL7(X,Y,Z)
- Q
- ;
- DDOK(PSJF,OI) ;Check to be sure all dispense drugs that are active in the
- ;order are valid.
- ; Input: PSJF - File root of the order including all but the IEN of
- ; the drug. (EX "^PS(53.45,X,2,")
- ; OI - IEN of the order's orderable item
- ; Output: 1 - all active DD's in the order are valid
- ; 0 - no DD's active DD's or at least one active is invalid
- N DDCNT,ND,PSJ,PSJ1 S (PSJ1,DDCNT)=0
- I '$D(PSGDT) D NOW^%DTC S PSGDT=+$E(%,1,12)
- I '$O(@(PSJF_"0)")) Q 1
- ; Naked reference below refers to ^PS(53.45, created using indirection in variable PSJF
- F PSJ=0:0 S PSJ=$O(@(PSJF_PSJ_")")) Q:'PSJ S ND=$G(@(PSJF_PSJ_",0)")) D
- .S DDCNT=DDCNT+1
- .S PSJ1=$S('$D(^PSDRUG(+ND,0)):1,$P($G(^(2)),U,3)'["U":1,+$G(^(2))'=+OI:1,$G(^("I"))="":0,1:^("I")'>PSGDT)
- Q $S('DDCNT:0,PSJ1=1:0,1:1)
- ;
- IVSET ;
- N P,DFN S DFN=PSJHLDFN,CHK=""
- F X=1:1:23 S P(X)=""
- S (P(2),P(3),P("NINITDT"))=+$P(DATA0,"^",5),P("LOG")=LOGIN,P(4)=$P(DATA0,"^",3),P(5)=$S(P(4)="S":$P(DATA0,"^",4),1:""),P(6)=PROVIDER,P(8)=$G(INFRT),P(9)=$G(SCHEDULE),P(17)="E",P(21)=PSJORDER,P(22)=LOC
- S:P(4)="P" P(9)=$P(DATA0,"^",6)
- I P(4)="S",P(5)=1 S P(9)=$P(DATA0,"^",6)
- S P("MR")=ROUTE
- I P("MR")="" S P("MR")=$S(P(4)="P":$O(^PS(51.2,"B","IV PIGGYBACK",0)),1:$O(^PS(51.2,"B","INTRAVENOUS",0)))
- S (P("CLRK"),P("NINIT"))=CLERK,P("PD")=PSITEM,(P("IVRM"),P("SYRS"),P("CLIN"),P("FRES"),P("OPI"))="",P("RES")=ROC,P("PRY")=$E(PRIORITY,2),P("REM")=""
- I $$SCHREQ^PSJLIVFD(.P),P(15)'>0 N P15 S P15=$$INTERVAL^PSIVUTL(.P)
- D CHKIV I CHK D ERROR Q
- D SETN
- D NEW55^PSIVORFB
- N DA,DIK,ND,PSIVACT
- S ND(0)=+ON55 F X=2:1:23 I $D(P(X)) S $P(ND(0),U,X)=P(X)
- S ND(.3)=$G(P("INS"))
- S $P(ND(0),U,17)="E",ND(1)=P("REM"),ND(3)=P("OPI"),ND(.2)=$P($G(P("PD")),U)_U_$G(P("DO"))_U_+P("MR")_U_$G(P("PRY"))_U_$G(ORDCON) F X=0,1,3,.2,.3 S ^PS(55,DFN,"IV",+ON55,X)=ND(X)
- S $P(^PS(55,DFN,"IV",+ON55,2),U,1,4)=P("LOG")_U_P("IVRM")_U_U_P("SYRS"),$P(^(2),U,8,10)=P("RES")_U_$G(P("FRES"))_U_$S($G(VAIN(4)):+VAIN(4),1:"")
- S $P(^PS(55,DFN,"IV",+ON55,2),U,11)=+P("CLRK")
- I +$G(P(22)) S $P(^PS(55,DFN,"IV",+ON55,"DSS"),"^")=P(22)_"^"_$G(APPT) D:$P(P("CLIN"),"^")'="" CIMOI^PSJIMO1(DFN,ON55)
- S:+$G(P("NINIT")) ^PS(55,DFN,"IV",+ON55,4)=P("NINIT")_U_P("NINITDT")_"^^^^^^^^"_"1"
- S ^PS(55,"APIV",DFN,+ON55)=""
- I $D(PROCOM) D
- .I '$D(^PS(55,DFN,"IV",+ON55,5,0)) S ^(0)=U_55.1115_U_0_U_0
- .S JJ=0 F S JJ=$O(PROCOM(JJ)) Q:'JJ S $P(^PS(55,DFN,"IV",+ON55,5,0),"^",3,4)=JJ_"^"_JJ,^PS(55,DFN,"IV",+ON55,5,JJ,0)=PROCOM(JJ)
- S ^PS(55,DFN,"IV",+ON55,3)=$$ENPC^PSJHL11("V",60)
- F DRGT="AD","SOL" D PUTD55
- K DA,DIK S DA(1)=DFN,DA=+ON55,DIK="^PS(55,"_DA(1)_",""IV"",",PSIVACT=1 D IX^DIK
- L -^PS(55,DFN,"IV",DA)
- S PSGORD=ON55
- Q
- ;
- PUTD55 ; Move drug data from local array into 55
- K ^PS(55,DFN,"IV",+ON55,DRGT) S ^PS(55,DFN,"IV",+ON55,DRGT,0)=$S(DRGT="AD":"^55.02PA",1:"^55.11IPA")
- F X=0:0 S X=$O(^TMP("PSB",$J,$S(DRGT="AD":800,1:900),X)) Q:'X D
- .S Y=^PS(55,DFN,"IV",+ON55,DRGT,0),$P(Y,U,3)=$P(Y,U,3)+1,DRG=$P(Y,U,3),$P(Y,U,4)=$P(Y,U,4)+1
- .S ^PS(55,DFN,"IV",+ON55,DRGT,0)=Y,^PS(55,DFN,"IV",+ON55,DRGT,+DRG,0)=$P(^TMP("PSB",$J,$S(DRGT="AD":800,1:900),X,0),"^")_"^"_$P(^TMP("PSJNVO",$J,DRGT,+DRG,0),"^",2)
- Q
- ;
- SETN ;Set up patient 0 node if needed.
- I '$D(^PS(55,DFN,0)) K DO,DA,DD,DIC,PSIVFN S:$D(^(5.1)) PSIVFN=^(5.1) K:$D(PSIVFN) ^(5.1) S (DINUM,X)=DFN,DIC(0)="L",DIC="^PS(55," D FILE^DICN S:$D(PSIVFN) ^PS(55,DFN,5.1)=PSIVFN D K DIC,PSIVFN,DO,DA,DD
- .; Mark PSJ and PSO as converted
- .S $P(^PS(55,DFN,5.1),"^",11)=2
- Q
- ;
- CHKIV ;Validate IV data
- N OK S OK=0
- I "APS"'[P(4) S CHK=1,PSREASON="Invalid IV Type" Q
- I P(9)="",P(4)="P" S CHK=1,PSREASON="Piggyback IV Type requires a schedule" Q
- I P(4)="S",P(5)=1,P(9)="" S CHK=1,PSREASON="Intermittent Syringe IV Type requires a schedule" Q
- I P(9)'="STAT",(P(9)'="NOW"),P(9)'="" S CHK=1,PSREASON="Invalid Schedule" Q
- I $D(^XUSEC("ORELSE",DUZ)),ORDCON'="V",ORDCON'="P" S CHK=1,PSREASON="Invalid Nature of Order" Q
- I +$G(^TMP("PSB",$J,800,0))=0,+$G(^TMP("PSB",$J,900,0))=0 S CHK=1,PSREASON="IV orders must have at least one additive or solution" Q
- I +$G(^TMP("PSB",$J,900,0))=0,P(4)'="P" S CHK=1,PSREASON="You must have at least one solution for this order." Q
- I +$G(^TMP("PSB",$J,800,0))'=+$G(^TMP("PSJNVO",$J,"AD",0)) S CHK=1,PSREASON="Number of additives in BCMA & CPRS do not match." Q
- I +$G(^TMP("PSB",$J,900,0))'=+$G(^TMP("PSJNVO",$J,"SOL",0)) S CHK=1,PSREASON="Number of solutions in BCMA & CPRS do not match." Q
- F DRGT="AD","SOL" S FIL=$S(DRGT="AD":52.6,1:52.7) F DRGI=0:0 S DRGI=$O(^TMP("PSB",$J,$S(DRGT="AD":800,1:900),DRGI)) Q:'DRGI S DRG=$G(^TMP("PSB",$J,$S(DRGT="AD":800,1:900),DRGI,0)) D DRG,@DRGT Q:CHK=1
- I 'OK,'CHK S CHK=1,PSREASON="The Orderable Item does not match any of the additives or solutions in this order" Q
- Q
- ;
- AD ;Check additives
- I '$D(^PS(FIL,+DRG,0)) S CHK=1,PSREASON="Additive "_+DRG_" does not exist in the additive file" Q
- ;Naked reference below refers to ^PS(52.6,+DRG,0)
- I $P(^(0),"^",11)=PSITEM S OK=1
- I $$ENU^PSIVUTL(+DRG)'=$P($P(^TMP("PSJNVO",$J,DRGT,+DRGI,0),"^",2)," ",2,99)!(+$P(^TMP("PSJNVO",$J,DRGT,+DRGI,0),"^",2)'>0) S CHK=1,PSREASON="Invalid strength entered for additive "_+DRG Q
- Q
- SOL ;Check solutions
- I '$D(^PS(FIL,+DRG,0)) S CHK=1,PSREASON="Solution "_+DRG_" does not exist in the solution file" Q
- ;Naked reference below refers to ^PS(52.7,+DRG,0)
- I $P(^(0),"^",11)=PSITEM S OK=1
- I +$P(^TMP("PSJNVO",$J,DRGT,+DRGI,0),"^",2)>9999!(+$P(^TMP("PSJNVO",$J,DRGT,+DRGI,0),"^",2)'>0) S CHK=1,PSREASON="Volume on "_+DRG_" is an invalid strength" Q
- Q
- DRG ;Check to be sure additive/solutions are active
- I $S('$G(^PS(FIL,+DRG,"I")):0,^("I")>DT:0,1:1) S CHK=1,PSREASON="An additive or solution is inactive" Q
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJHL10 9983 printed Jan 18, 2025@03:08:08 Page 2
- PSJHL10 ;BIR/LDT,BSJ-VALIDATE INCOMING HL7 DATA/CREATE NEW ORDER ;30 MAY 07
- +1 ;;5.0;INPATIENT MEDICATIONS;**58,78,91,109,110,195,257,307**;16 DEC 97;Build 18
- +2 ;
- +3 ; Reference to ^PSDRUG is supported by DBIA# 2192.
- +4 ; Reference to ^PS(51.2 is supported by DBIA# 2178.
- +5 ; Reference to ^PS(55 is supported by DBIA# 2191.
- +6 ; Reference to ^PS(52.6 is supported by DBIA# 1231.
- +7 ; Reference to ^PS(52.7 is supported by DBIA# 2173.
- +8 ; Reference to ^PSBAPIPM is supported by DBIA# 3564.
- +9 ; Reference to ^ORERR is supported by DBIA# 2187.
- +10 ;
- VALID ;
- +1 ;Call BCMA for rest of data
- +2 DO MOB^PSBAPIPM(PSJHLDFN,+PSJORDER)
- +3 NEW DATA0,CHK
- SET DATA0=$GET(^TMP("PSB",$JOB,0))
- IF DATA0=-1
- SET PSREASON="""YOUR ORDER WAS NOT SAVED. EXIT BCMA, SIGN BACK IN, THEN TRY AGAIN."""
- DO ERROR
- QUIT
- +4 IF $PIECE(DATA0,"^")'=PSJHLDFN
- SET PSREASON="Patient does not match"
- DO ERROR
- QUIT
- +5 IF $PIECE(DATA0,"^",2)'=+PSJORDER
- SET PSREASON="Order number does not match"
- DO ERROR
- QUIT
- +6 NEW VAIP
- SET DFN=PSJHLDFN
- SET VAIP("D")=$GET(LOGIN)
- DO IN5^VADPT
- +7 ;If UD do UD set/validate.
- +8 IF $PIECE(DATA0,"^",3)=""
- DO UDSET
- +9 ;If IV do IV set/validate.
- +10 IF $PIECE(DATA0,"^",3)]""
- DO IVSET
- +11 if 'CHK
- DO EN1^PSJHL2(PSJHLDFN,"OK",PSGORD)
- DO EN1^PSJHL2(PSJHLDFN,"SC",PSGORD)
- DO EN1^PSJHL2(PSJHLDFN,"ZV",PSGORD)
- DO MOBR^PSBAPIPM(PSJHLDFN,+PSJORDER,PSGORD)
- +12 QUIT
- +13 ;
- ERROR ;Sends error msg to CPRS, logs error in OE/RR Errors file
- +1 SET X="ORERR"
- XECUTE ^%ZOSF("TEST")
- IF $TEST
- DO EN^ORERR(PSREASON,.PSJMSG)
- DO MOBR^PSBAPIPM(PSJHLDFN,+PSJORDER)
- +2 DO EN1^PSJHLERR(PSJHLDFN,"OC",PSJORDER,PSREASON)
- SET QFLG=1
- KILL ^TMP("PSJNVO",$JOB),^TMP("PSB",$JOB)
- +3 QUIT
- +4 ;
- UDSET ;Set up UD variables
- +1 NEW PSGPR,PSGMR,PSGSM,PSGHSM,PSGST,PSGP,PSGSCH,PSGPDRG,PSGDO,PSGNESD,PSGNEFD,PSGOEAV,PSJSYSU,PSGS0XT,PSGS0Y
- +2 SET PSGPR=PROVIDER
- SET PSGMR=ROUTE
- SET PSGSM=0
- SET PSGHSM=""
- SET PSGST="O"
- SET PSGP=PSJHLDFN
- SET PSGSCH=SCHEDULE
- SET PSGPDRG=PSITEM
- +3 SET (PSGNESD,PSGNEFD)=+$PIECE(DATA0,"^",5)
- SET PSGOEAV=1
- SET PSJSYSU=1
- SET PSGS0XT="O"
- SET PSGS0Y=""
- +4 IF $GET(DOSE)]""
- IF $GET(UNIT)]""
- SET PSGDO=DOSE_UNIT
- +5 IF $GET(PSGDO)']""
- IF $GET(INSTR)]""
- SET PSGDO=$$TRIM^XLFSTR(INSTR,"R"," ")
- +6 SET CHK=""
- +7 SET ND=U_PSGPR_U_PSGMR_"^U^"_PSGSM_U_PSGHSM_U_PSGST_"^^"_"E"_"^^^^^"_LOGIN_U_PSGP_U_LOGIN
- +8 DO CHK("^^"_PSGMR_"^^^^"_PSGST,PSGPDRG_U_PSGDO,PSGSCH_U_PSGNESD_"^^"_PSGNEFD)
- +9 IF CHK
- DO ERROR
- QUIT
- +10 IF PSGSCH'="STAT"
- IF PSGSCH'="NOW"
- SET PSREASON="Invalid Schedule"
- SET CHK=1
- DO ERROR
- QUIT
- +11 IF $DATA(^XUSEC("ORELSE",DUZ))
- IF ORDCON'="V"
- IF ORDCON'="P"
- SET PSREASON="Invalid Nature of Order"
- SET CHK=1
- DO ERROR
- QUIT
- +12 if '$DATA(^PS(55,PSGP,0))
- DO ENSET0^PSGNE3(PSGP)
- SET $PIECE(^PS(55,PSGP,5.1),U,2)=PSGPR
- SET PSGOEPR=PSGPR
- +13 SET ND0=ND
- DO ENGNA^PSGOETO
- +14 IF $DATA(^PS(51.2,+PSGMR,0))
- IF $PIECE(^(0),U,3)]""
- SET PSGMRN=$PIECE(^(0),U,3)
- +15 SET ND0=DA_ND0
- +16 SET $PIECE(ND0,"^",21)=PSJORDER
- +17 SET ND2=PSGSCH_U_PSGNESD_"^^"_PSGNEFD_U_PSGS0Y_U_PSGS0XT_"^^^^"_+VAIP(5)
- +18 SET $PIECE(ND4,U,7)=DUZ
- IF PSGOEAV
- IF PSJSYSU
- Begin DoDot:1
- +19 SET $PIECE(ND4,U,PSJSYSU,PSJSYSU+1)=DUZ_U_+$PIECE(DATA0,"^",5)
- SET $PIECE(ND4,U,+PSJSYSU=1+9)=1
- SET $PIECE(ND4,U,+PSJSYSU=3+9)=0
- +20 SET $PIECE(ND4,U,9,10)=+$PIECE(ND4,U,9)_U_+$PIECE(ND4,U,10)
- +21 IF '$PIECE(ND4,U,9)
- SET ^PS(55,"APV",PSGP,DA)=""
- +22 IF '$PIECE(ND4,U,10)
- SET ^PS(55,"NPV",PSGP,DA)=""
- +23 IF $PIECE(ND4,U,9)
- KILL ^PS(55,"APV",PSGP,DA)
- +24 IF $PIECE(ND4,U,10)
- KILL ^PS(55,"NPV",PSGP,DA)
- End DoDot:1
- +25 SET F="^PS(55,"_PSGP_",5,"_DA_","
- SET @(F_"0)")=ND0
- +26 ;naked reference on the four (4) lines below refer to the full ref to ^PS(55,PSGP,5,DA created by indirection using variable F
- +27 IF $GET(INSTR)]""
- SET @(F_".3)")=INSTR
- +28 SET @(F_".2)")=PSGPDRG_U_PSGDO
- SET $PIECE(^(.2),U,3,6)=$GET(ORDCON)_"^"_$EXTRACT(PRIORITY,2)_"^"_$GET(DOSE)_"^"_$GET(UNIT)
- +29 SET @(F_"2)")=ND2
- SET ^(4)=ND4
- +30 SET (C,X)=0
- FOR
- SET X=$ORDER(^TMP("PSB",$JOB,700,X))
- if 'X
- QUIT
- SET D=$GET(^(X,0))
- IF D
- SET C=C+1
- SET @(F_"1,"_C_",0)")=$PIECE(D,U,1,2)
- SET @(F_"1,""B"","_+D_","_C_")")=""
- +31 if C
- SET @(F_"1,0)")=U_"55.07P^"_C_U_C
- +32 IF $DATA(PROCOM)
- Begin DoDot:1
- +33 ;naked refs on the four lines below refer to the full ref to ^PS(55,PSGP,5,DA created by indrection using variable F
- +34 IF '$DATA(@(F_"12,0)"))
- SET ^(0)=U_55.0612_U_0_U_0
- +35 SET JJ=0
- FOR
- SET JJ=$ORDER(PROCOM(JJ))
- if 'JJ
- QUIT
- SET $PIECE(@(F_"12,0)"),"^",3,4)=JJ_"^"_JJ
- SET @(F_"12,"_JJ_",0)")=PROCOM(JJ)
- End DoDot:1
- +36 SET @(F_"6)")=$$ENPC^PSJHL11("U",180)
- +37 IF $GET(APPT)]""
- SET @(F_"8)")=LOC_"^"_APPT
- +38 DO CIMOU^PSJIMO1(PSGP,DA)
- +39 DO CRA^PSGOETO
- +40 LOCK -^PS(55,DFN,5,DA)
- +41 SET PSGORD=DA_"U"
- OUT ;
- +1 QUIT
- +2 ;
- CHK(X,Y,Z) ;Check for required fields
- +1 ; Input: X="^^"_MED ROUTE_"^^^^"_SCH TYPE
- +2 ; Y=ORDERABLE ITEM_"^"_DOSAGE ORDERED
- +3 ; Z=SCHEDULE_"^"_START DATE/TIME_"^^"_STOP DATE/TIME
- +4 DO CHK^PSJHL7(X,Y,Z)
- +5 QUIT
- +6 ;
- DDOK(PSJF,OI) ;Check to be sure all dispense drugs that are active in the
- +1 ;order are valid.
- +2 ; Input: PSJF - File root of the order including all but the IEN of
- +3 ; the drug. (EX "^PS(53.45,X,2,")
- +4 ; OI - IEN of the order's orderable item
- +5 ; Output: 1 - all active DD's in the order are valid
- +6 ; 0 - no DD's active DD's or at least one active is invalid
- +7 NEW DDCNT,ND,PSJ,PSJ1
- SET (PSJ1,DDCNT)=0
- +8 IF '$DATA(PSGDT)
- DO NOW^%DTC
- SET PSGDT=+$EXTRACT(%,1,12)
- +9 IF '$ORDER(@(PSJF_"0)"))
- QUIT 1
- +10 ; Naked reference below refers to ^PS(53.45, created using indirection in variable PSJF
- +11 FOR PSJ=0:0
- SET PSJ=$ORDER(@(PSJF_PSJ_")"))
- if 'PSJ
- QUIT
- SET ND=$GET(@(PSJF_PSJ_",0)"))
- Begin DoDot:1
- +12 SET DDCNT=DDCNT+1
- +13 SET PSJ1=$SELECT('$DATA(^PSDRUG(+ND,0)):1,$PIECE($GET(^(2)),U,3)'["U":1,+$GET(^(2))'=+OI:1,$GET(^("I"))="":0,1:^("I")'>PSGDT)
- End DoDot:1
- +14 QUIT $SELECT('DDCNT:0,PSJ1=1:0,1:1)
- +15 ;
- IVSET ;
- +1 NEW P,DFN
- SET DFN=PSJHLDFN
- SET CHK=""
- +2 FOR X=1:1:23
- SET P(X)=""
- +3 SET (P(2),P(3),P("NINITDT"))=+$PIECE(DATA0,"^",5)
- SET P("LOG")=LOGIN
- SET P(4)=$PIECE(DATA0,"^",3)
- SET P(5)=$SELECT(P(4)="S":$PIECE(DATA0,"^",4),1:"")
- SET P(6)=PROVIDER
- SET P(8)=$GET(INFRT)
- SET P(9)=$GET(SCHEDULE)
- SET P(17)="E"
- SET P(21)=PSJORDER
- SET P(22)=LOC
- +4 if P(4)="P"
- SET P(9)=$PIECE(DATA0,"^",6)
- +5 IF P(4)="S"
- IF P(5)=1
- SET P(9)=$PIECE(DATA0,"^",6)
- +6 SET P("MR")=ROUTE
- +7 IF P("MR")=""
- SET P("MR")=$SELECT(P(4)="P":$ORDER(^PS(51.2,"B","IV PIGGYBACK",0)),1:$ORDER(^PS(51.2,"B","INTRAVENOUS",0)))
- +8 SET (P("CLRK"),P("NINIT"))=CLERK
- SET P("PD")=PSITEM
- SET (P("IVRM"),P("SYRS"),P("CLIN"),P("FRES"),P("OPI"))=""
- SET P("RES")=ROC
- SET P("PRY")=$EXTRACT(PRIORITY,2)
- SET P("REM")=""
- +9 IF $$SCHREQ^PSJLIVFD(.P)
- IF P(15)'>0
- NEW P15
- SET P15=$$INTERVAL^PSIVUTL(.P)
- +10 DO CHKIV
- IF CHK
- DO ERROR
- QUIT
- +11 DO SETN
- +12 DO NEW55^PSIVORFB
- +13 NEW DA,DIK,ND,PSIVACT
- +14 SET ND(0)=+ON55
- FOR X=2:1:23
- IF $DATA(P(X))
- SET $PIECE(ND(0),U,X)=P(X)
- +15 SET ND(.3)=$GET(P("INS"))
- +16 SET $PIECE(ND(0),U,17)="E"
- SET ND(1)=P("REM")
- SET ND(3)=P("OPI")
- SET ND(.2)=$PIECE($GET(P("PD")),U)_U_$GET(P("DO"))_U_+P("MR")_U_$GET(P("PRY"))_U_$GET(ORDCON)
- FOR X=0,1,3,.2,.3
- SET ^PS(55,DFN,"IV",+ON55,X)=ND(X)
- +17 SET $PIECE(^PS(55,DFN,"IV",+ON55,2),U,1,4)=P("LOG")_U_P("IVRM")_U_U_P("SYRS")
- SET $PIECE(^(2),U,8,10)=P("RES")_U_$GET(P("FRES"))_U_$SELECT($GET(VAIN(4)):+VAIN(4),1:"")
- +18 SET $PIECE(^PS(55,DFN,"IV",+ON55,2),U,11)=+P("CLRK")
- +19 IF +$GET(P(22))
- SET $PIECE(^PS(55,DFN,"IV",+ON55,"DSS"),"^")=P(22)_"^"_$GET(APPT)
- if $PIECE(P("CLIN"),"^")'=""
- DO CIMOI^PSJIMO1(DFN,ON55)
- +20 if +$GET(P("NINIT"))
- SET ^PS(55,DFN,"IV",+ON55,4)=P("NINIT")_U_P("NINITDT")_"^^^^^^^^"_"1"
- +21 SET ^PS(55,"APIV",DFN,+ON55)=""
- +22 IF $DATA(PROCOM)
- Begin DoDot:1
- +23 IF '$DATA(^PS(55,DFN,"IV",+ON55,5,0))
- SET ^(0)=U_55.1115_U_0_U_0
- +24 SET JJ=0
- FOR
- SET JJ=$ORDER(PROCOM(JJ))
- if 'JJ
- QUIT
- SET $PIECE(^PS(55,DFN,"IV",+ON55,5,0),"^",3,4)=JJ_"^"_JJ
- SET ^PS(55,DFN,"IV",+ON55,5,JJ,0)=PROCOM(JJ)
- End DoDot:1
- +25 SET ^PS(55,DFN,"IV",+ON55,3)=$$ENPC^PSJHL11("V",60)
- +26 FOR DRGT="AD","SOL"
- DO PUTD55
- +27 KILL DA,DIK
- SET DA(1)=DFN
- SET DA=+ON55
- SET DIK="^PS(55,"_DA(1)_",""IV"","
- SET PSIVACT=1
- DO IX^DIK
- +28 LOCK -^PS(55,DFN,"IV",DA)
- +29 SET PSGORD=ON55
- +30 QUIT
- +31 ;
- PUTD55 ; Move drug data from local array into 55
- +1 KILL ^PS(55,DFN,"IV",+ON55,DRGT)
- SET ^PS(55,DFN,"IV",+ON55,DRGT,0)=$SELECT(DRGT="AD":"^55.02PA",1:"^55.11IPA")
- +2 FOR X=0:0
- SET X=$ORDER(^TMP("PSB",$JOB,$SELECT(DRGT="AD":800,1:900),X))
- if 'X
- QUIT
- Begin DoDot:1
- +3 SET Y=^PS(55,DFN,"IV",+ON55,DRGT,0)
- SET $PIECE(Y,U,3)=$PIECE(Y,U,3)+1
- SET DRG=$PIECE(Y,U,3)
- SET $PIECE(Y,U,4)=$PIECE(Y,U,4)+1
- +4 SET ^PS(55,DFN,"IV",+ON55,DRGT,0)=Y
- SET ^PS(55,DFN,"IV",+ON55,DRGT,+DRG,0)=$PIECE(^TMP("PSB",$JOB,$SELECT(DRGT="AD":800,1:900),X,0),"^")_"^"_$PIECE(^TMP("PSJNVO",$JOB,DRGT,+DRG,0),"^",2)
- End DoDot:1
- +5 QUIT
- +6 ;
- SETN ;Set up patient 0 node if needed.
- +1 IF '$DATA(^PS(55,DFN,0))
- KILL DO,DA,DD,DIC,PSIVFN
- if $DATA(^(5.1))
- SET PSIVFN=^(5.1)
- if $DATA(PSIVFN)
- KILL ^(5.1)
- SET (DINUM,X)=DFN
- SET DIC(0)="L"
- SET DIC="^PS(55,"
- DO FILE^DICN
- if $DATA(PSIVFN)
- SET ^PS(55,DFN,5.1)=PSIVFN
- Begin DoDot:1
- +2 ; Mark PSJ and PSO as converted
- +3 SET $PIECE(^PS(55,DFN,5.1),"^",11)=2
- End DoDot:1
- KILL DIC,PSIVFN,DO,DA,DD
- +4 QUIT
- +5 ;
- CHKIV ;Validate IV data
- +1 NEW OK
- SET OK=0
- +2 IF "APS"'[P(4)
- SET CHK=1
- SET PSREASON="Invalid IV Type"
- QUIT
- +3 IF P(9)=""
- IF P(4)="P"
- SET CHK=1
- SET PSREASON="Piggyback IV Type requires a schedule"
- QUIT
- +4 IF P(4)="S"
- IF P(5)=1
- IF P(9)=""
- SET CHK=1
- SET PSREASON="Intermittent Syringe IV Type requires a schedule"
- QUIT
- +5 IF P(9)'="STAT"
- IF (P(9)'="NOW")
- IF P(9)'=""
- SET CHK=1
- SET PSREASON="Invalid Schedule"
- QUIT
- +6 IF $DATA(^XUSEC("ORELSE",DUZ))
- IF ORDCON'="V"
- IF ORDCON'="P"
- SET CHK=1
- SET PSREASON="Invalid Nature of Order"
- QUIT
- +7 IF +$GET(^TMP("PSB",$JOB,800,0))=0
- IF +$GET(^TMP("PSB",$JOB,900,0))=0
- SET CHK=1
- SET PSREASON="IV orders must have at least one additive or solution"
- QUIT
- +8 IF +$GET(^TMP("PSB",$JOB,900,0))=0
- IF P(4)'="P"
- SET CHK=1
- SET PSREASON="You must have at least one solution for this order."
- QUIT
- +9 IF +$GET(^TMP("PSB",$JOB,800,0))'=+$GET(^TMP("PSJNVO",$JOB,"AD",0))
- SET CHK=1
- SET PSREASON="Number of additives in BCMA & CPRS do not match."
- QUIT
- +10 IF +$GET(^TMP("PSB",$JOB,900,0))'=+$GET(^TMP("PSJNVO",$JOB,"SOL",0))
- SET CHK=1
- SET PSREASON="Number of solutions in BCMA & CPRS do not match."
- QUIT
- +11 FOR DRGT="AD","SOL"
- SET FIL=$SELECT(DRGT="AD":52.6,1:52.7)
- FOR DRGI=0:0
- SET DRGI=$ORDER(^TMP("PSB",$JOB,$SELECT(DRGT="AD":800,1:900),DRGI))
- if 'DRGI
- QUIT
- SET DRG=$GET(^TMP("PSB",$JOB,$SELECT(DRGT="AD":800,1:900),DRGI,0))
- DO DRG
- DO @DRGT
- if CHK=1
- QUIT
- +12 IF 'OK
- IF 'CHK
- SET CHK=1
- SET PSREASON="The Orderable Item does not match any of the additives or solutions in this order"
- QUIT
- +13 QUIT
- +14 ;
- AD ;Check additives
- +1 IF '$DATA(^PS(FIL,+DRG,0))
- SET CHK=1
- SET PSREASON="Additive "_+DRG_" does not exist in the additive file"
- QUIT
- +2 ;Naked reference below refers to ^PS(52.6,+DRG,0)
- +3 IF $PIECE(^(0),"^",11)=PSITEM
- SET OK=1
- +4 IF $$ENU^PSIVUTL(+DRG)'=$PIECE($PIECE(^TMP("PSJNVO",$JOB,DRGT,+DRGI,0),"^",2)," ",2,99)!(+$PIECE(^TMP("PSJNVO",$JOB,DRGT,+DRGI,0),"^",2)'>0)
- SET CHK=1
- SET PSREASON="Invalid strength entered for additive "_+DRG
- QUIT
- +5 QUIT
- SOL ;Check solutions
- +1 IF '$DATA(^PS(FIL,+DRG,0))
- SET CHK=1
- SET PSREASON="Solution "_+DRG_" does not exist in the solution file"
- QUIT
- +2 ;Naked reference below refers to ^PS(52.7,+DRG,0)
- +3 IF $PIECE(^(0),"^",11)=PSITEM
- SET OK=1
- +4 IF +$PIECE(^TMP("PSJNVO",$JOB,DRGT,+DRGI,0),"^",2)>9999!(+$PIECE(^TMP("PSJNVO",$JOB,DRGT,+DRGI,0),"^",2)'>0)
- SET CHK=1
- SET PSREASON="Volume on "_+DRG_" is an invalid strength"
- QUIT
- +5 QUIT
- DRG ;Check to be sure additive/solutions are active
- +1 IF $SELECT('$GET(^PS(FIL,+DRG,"I")):0,^("I")>DT:0,1:1)
- SET CHK=1
- SET PSREASON="An additive or solution is inactive"
- QUIT
- +2 QUIT