- PSJHL9 ;BIR/LDT - VALIDATE INCOMING HL7 DATA/CREATE NEW ORDER ;Aug 26, 2020@15:04:51
- ;;5.0;INPATIENT MEDICATIONS;**1,18,31,42,47,50,63,72,75,58,80,110,111,134,267,279,194,388,399**;16 DEC 97;Build 64
- ;
- ; Reference to ^PSDRUG is supported by DBIA# 2192.
- ; Reference to ^PS(50.7 is supported by DBIA# 2180.
- ; Reference to ^PS(51.2 is supported by DBIA# 2178.
- ; Reference to ^PS(55 is supported by DBIA# 2191.
- ; Reference to ^ORERR is supported by DBIA# 2187.
- ; Reference to ^ORHLESC is supported by DBIA# 4922.
- ;
- VALID ;
- I APPL="",PSITEM="" S PSREASON="Missing or invalid Orderable Item" D ERROR Q
- I PSITEM]"",'$D(^PS(50.7,+PSITEM,0)) S PSREASON="Missing or invalid Orderable Item" D ERROR Q
- I $G(APPL)'["B",$G(APPL)'["A",+$G(ROUTE)'>0 S PSREASON="Missing or invalid Med Route" D ERROR Q
- S APPL=$S($G(APPL)["B":"F",$G(APPL)["A":"F",$G(DISPENSE)]"":$$ORTYP(ROUTE,DISPENSE),1:$$TRYAGAIN(ROUTE,PSITEM))
- S:APPL="" APPL="IP"
- I APPL'="F" D
- .I $G(SCHEDULE)]"" N X S X=SCHEDULE D S SCHEDULE=X
- ..;*194 Allow multi-word schedules
- ..I X[""""!($A(X)=45)!(X?.E1C.E)!($L(X," ")>$S(X["PRN":4,1:3))!($L($P(X,"@"))>70)!($L($P(X,"@",2))>119)!($L(X)<1)!(X["P RN")!(X["PR N") S X="" Q
- ..I X?.E1L.E S X=$$ENLU^PSGMI(X)
- ..S X=$$TRIM^XLFSTR(X,"R"," ")
- ..I X["Q0" S X="" Q
- .I APPL["U",$G(SCHEDULE)="" S PSREASON="Missing or invalid schedule" D ERROR Q
- .N DFN S DFN=PSJHLDFN D IN5^VADPT I 'VAIP(5) D:APPT="" I APPL="UN",APPT="" S PSREASON="Cannot place Unit Dose orders for an Outpatient" D ERROR Q
- .. I APPL="UP" S APPL="IN" Q
- .. I APPL="IP" S APPL="IN" Q
- .I $G(ROC)'="R",$G(ROUTE)'>0 S PSREASON="Missing or invalid Med Route" D ERROR Q
- I APPL="F" D
- .I '$O(^TMP("PSJNVO",$J,"SOL",0))&('$O(^TMP("PSJNVO",$J,"AD",0))) S PSREASON="IV Fluid orders must have at least one additive or solution" D ERROR Q
- .I $G(IVCAT)="I",$G(INFRT)="" Q ;Allow intermittent IV orders to have a null infusion rate.
- .I $G(INFRT)="" S PSREASON="Invalid Infusion Rate" D ERROR Q
- 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)
- D EN1^PSJHLERR(PSJHLDFN,$S(PSOC="XO":"UX",1:"OC"),$P(ORDER,U),PSREASON) S QFLG=1 K ^TMP("PSJNVO",$J)
- Q
- ;
- NVO ; put new orders in non-verified orders file
- I '$D(ROUTE) S ROUTE=""
- I $G(ROUTE)="" S:APPL="F" ROUTE=$O(^PS(51.2,"B","INTRAVENOUS",0))
- N DA,DR,DIE D ENGNN^PSGOETO S DIE="^PS(53.1,"
- S DR="1////"_PROVIDER_";3////"_$$ESC^ORHLESC(ROUTE)_";4////"_$E(APPL)_";28////P"_";108////"_PSITEM_";27.1////"_LOGIN_";27////"_LOGIN_";.5////"_PSJHLDFN_";.24////"_PRIORITY_";125////"_$G(PRNTON)
- I $G(LOC)]"" S:$P($G(^SC(+LOC,0)),U,3)="C" DR=DR_";113////"_LOC_";126////"_$G(APPT)
- I $G(IVCAT)]"" S DR=DR_";128////"_IVCAT S ADMINS=""
- S:$G(SCHTYP)]"" DR=DR_";7////"_SCHTYP
- D ^DIE K PSJHLSKP S NEWORDER=DA,PSJORDER=DA_"P"
- S $P(^PS(55,PSJHLDFN,5.1),"^",2)=PROVIDER
- S:$G(ORDER)]"" $P(^PS(53.1,DA,0),"^",21)=$P(ORDER,"^")
- S:$G(APPL)["P" $P(^PS(53.1,DA,0),"^",13)=1
- S $P(^PS(53.1,DA,0),"^",18)=DA
- S:$G(ROC)]"" $P(^PS(53.1,DA,0),"^",24)=ROC
- S:$G(PREON)]"" $P(^PS(53.1,DA,0),"^",25)=PREON
- S:$G(ADMINS) $P(^PS(53.1,DA,2),"^",5)=ADMINS
- S:$G(REQST)]"" $P(^PS(53.1,DA,2.5),"^")=REQST
- ; Transform duration units of doses to a for administrations
- S:$E(DURATION,1,5)="doses" DURATION=$TR(DURATION,"doses","a")
- S:$G(DURATION)]"" $P(^PS(53.1,DA,2.5),"^",2)=DURATION
- S:$G(IVLIMIT)]"" $P(^PS(53.1,DA,2.5),"^",4)=IVLIMIT
- I $G(REQST)]"",$G(DURATION)]"" S $P(^PS(53.1,DA,2.5),"^",3)=$$STOP(REQST,DURATION)
- S:$G(INSTR)]"" $P(^PS(53.1,DA,.3),"^")=INSTR
- I $G(INFRT)]"" D
- .I INFRT S:(INFRT["Minutes"!(INFRT["Hours")) INFRT="INFUSE OVER "_INFRT
- .S ^PS(53.1,DA,8)=IVTYP_"^^^^"_INFRT
- .I INFRT["@",($P(INFRT,"@",2)?1.N) S $P(^PS(53.1,DA,17),"^")=$P(INFRT,"@",2)
- S:$G(FREQ)]"" $P(^PS(53.1,DA,2),"^",6)=FREQ
- S:$G(SCHTYP)]"" $P(^PS(53.1,DA,0),"^",7)=SCHTYP
- I $G(APPL)'="I" I $G(INSTR)]"" N X S X=INSTR D STRIP I $S(X?.E1C.E:0,$L(X)>60:0,X="":0,X["^":0,X?1.P:1,1:1) S $P(^PS(53.1,DA,.2),"^",2)=X,$P(^PS(53.1,DA,.2),"^",5,6)=$G(DOSE)_"^"_$$UNESC^ORHLESC($G(UNIT))
- S $P(^PS(53.1,DA,.2),"^",3)=ORDCON
- I $G(SCHEDULE)]"" S $P(^PS(53.1,DA,2),"^")=$$UNESC^ORHLESC(SCHEDULE)
- I $G(APPL)="I" I $G(UNITS)]"" S $P(^PS(53.1,DA,.3),"^")=$$UNESC^ORHLESC(UNITS)
- S ^PS(53.1,DA,4)="^^^^^^"_CLERK
- I $G(DISPENSE) S ^PS(53.1,DA,1,0)="^53.11P^1^1",^PS(53.1,DA,1,1,0)=DISPENSE_"^"_$$UNESC^ORHLESC(UNITS),^PS(53.1,DA,1,"B",$E(DISPENSE,1,30),1)=""
- I $D(PROCOM) D
- .I '$D(^PS(53.1,DA,12,0)) S ^(0)="^53.1012^0^0"
- .S JJ=0 F S JJ=$O(PROCOM(JJ)) Q:'JJ S $P(^PS(53.1,DA,12,0),"^",3,4)=JJ_"^"_JJ,^PS(53.1,DA,12,JJ,0)=$$UNESC^ORHLESC(PROCOM(JJ))
- S ^PS(53.1,DA,18)=$$UNESC^ORHLESC(PSJINDI) ;*399-IND
- I $D(ADMINSTR) D
- .I '$D(^PS(53.1,DA,3,0)) S ^(0)="^53.12^0^0"
- .S JJ=0 F S JJ=$O(ADMINSTR(JJ)) Q:'JJ S $P(^PS(53.1,DA,3,0),"^",3,4)=JJ_"^"_JJ,^PS(53.1,DA,3,JJ,0)=ADMINSTR(JJ)
- I $D(^TMP("PSJNVO",$J,"AD")) D
- .S ^PS(53.1,DA,"AD",0)="^53.157PA^0^0"
- .S JJ=0 F S JJ=$O(^TMP("PSJNVO",$J,"AD",JJ)) Q:'JJ S $P(^PS(53.1,DA,"AD",0),"^",3,4)=JJ_"^"_JJ,^PS(53.1,DA,"AD",JJ,0)=^TMP("PSJNVO",$J,"AD",JJ,0),^PS(53.1,DA,"AD","B",$$UNESC^ORHLESC($P(^TMP("PSJNVO",$J,"AD",JJ,0),"^")),JJ)=""
- I $D(^TMP("PSJNVO",$J,"SOL")) D
- .S ^PS(53.1,DA,"SOL",0)="^53.158PA^0^0"
- .S JJ=0 F S JJ=$O(^TMP("PSJNVO",$J,"SOL",JJ)) Q:'JJ S $P(^PS(53.1,DA,"SOL",0),"^",3,4)=JJ_"^"_JJ,^PS(53.1,DA,"SOL",JJ,0)=^TMP("PSJNVO",$J,"SOL",JJ,0),^PS(53.1,DA,"SOL","B",$P(^TMP("PSJNVO",$J,"SOL",JJ,0),"^"),JJ)=""
- I $O(^TMP("PSJNVO",$J,10,0)) D
- .S ^PS(53.1,DA,10,0)="^53.1112A^0^0"
- .S JJ=0 F S JJ=$O(^TMP("PSJNVO",$J,10,JJ)) Q:'JJ S $P(^PS(53.1,DA,10,0),"^",3,4)=JJ_"^"_JJ,^PS(53.1,DA,10,JJ,0)=$$UNESC^ORHLESC(^TMP("PSJNVO",$J,10,JJ,0)),^PS(53.1,DA,10,"B",$$UNESC^ORHLESC($E(^TMP("PSJNVO",$J,10,JJ,0),1,30)),JJ)="" D
- ..S ^PS(53.1,DA,10,JJ,1)=$P($G(^VA(200,+CLERK,0)),"^")
- ..I $O(^TMP("PSJNVO",$J,10,JJ,2,0)) S ^PS(53.1,DA,10,JJ,2,0)="^53.11122^0^0" D
- ...S QQ=0 F S QQ=$O(^TMP("PSJNVO",$J,10,JJ,2,QQ)) Q:'QQ S $P(^PS(53.1,DA,10,JJ,2,0),"^",3,4)=QQ_"^"_QQ,^PS(53.1,DA,10,JJ,2,QQ,0)=$$UNESC^ORHLESC(^TMP("PSJNVO",$J,10,JJ,2,QQ,0))
- Q
- STRIP ;Strips spaces off the end of instructions.
- I $E(X,$L(X))=" " F S X=$E(X,1,$L(X)-1) Q:$E(X,$L(X))'=" "
- Q
- ;
- ORTYP(MDRT,DDRG) ;Entry point to determine order type for 53.1
- ;MDRT=Med Route from 51.2, DDRG=Dispense Drug
- I '$G(DDRG) S ORTYP="" Q ORTYP
- I '$D(^PSDRUG(+DDRG,2)) S ORTYP="" Q ORTYP
- I $P(^PSDRUG(DDRG,2),"^",3)'["I",$P(^PSDRUG(DDRG,2),"^",3)'["U" S ORTYP="" Q ORTYP
- I '$G(MDRT) S ORTYP="" Q ORTYP
- I '$D(^PS(51.2,+MDRT,0)) S ORTYP="" Q ORTYP
- I $P(^PSDRUG(DDRG,2),"^",3)["I",$P(^PSDRUG(DDRG,2),"^",3)'["U",$P(^PS(51.2,MDRT,0),"^",6)=1 S ORTYP="IN" Q ORTYP
- I $P(^PSDRUG(DDRG,2),"^",3)'["I",$P(^PS(51.2,MDRT,0),"^",6)=1 S ORTYP="UP" Q ORTYP
- I $P(^PSDRUG(DDRG,2),"^",3)["I",$P(^PS(51.2,MDRT,0),"^",6)=1 S ORTYP="IP" Q ORTYP
- I $P(^PSDRUG(DDRG,2),"^",3)["I",$P(^PSDRUG(DDRG,2),"^",3)'["U",$P(^PS(51.2,MDRT,0),"^",6)'=1 S ORTYP="IP" Q ORTYP
- I $P(^PSDRUG(DDRG,2),"^",3)["U",$P(^PSDRUG(DDRG,2),"^",3)'["I",$P(^PS(51.2,MDRT,0),"^",6)'=1 S ORTYP="UN" Q ORTYP
- I $P(^PSDRUG(DDRG,2),"^",3)["U",$P(^PS(51.2,MDRT,0),"^",6)'=1 S ORTYP="UP" Q ORTYP
- S ORTYP="" Q ORTYP
- ;
- TRYAGAIN(MDRT,OI) ;
- ;MDRT=Med Route from 51.2, OI=Orderable Item
- N ORTYPI,ORTYPU,ORTYPP
- S ORTYP="",ORTYPI=0,ORTYPU=0,ORTYPP=0
- N DDRG S DDRG=0 F S DDRG=$O(^PSDRUG("ASP",OI,DDRG)) Q:'DDRG D
- .I $G(^PSDRUG(DDRG,"I"))]"" Q:^PSDRUG(DDRG,"I")'>DT
- .S ORTYP=$$ORTYP(MDRT,DDRG) D
- ..I ORTYP["I" S ORTYPI=ORTYPI+1
- ..I ORTYP["U" S ORTYPU=ORTYPU+1
- ..I ORTYP["P" S ORTYPP=ORTYPP+1
- S ORTYP=$S(ORTYPU>ORTYPI:"U",1:"I") S ORTYP=ORTYP_$S(ORTYPP>0:"P",1:"N")
- Q ORTYP
- ;
- STOP(REQST,DURA) ;
- ;REQST=Requested start date, DURA=Duration from CPRS
- I DURA["L",DURA?1A1".".N S DAYS=$$DAY($E(REQST,1,5)),DURA="H"_((DAYS*$P(DURA,"L",2))*24)
- I DURA["L",DURA?1A.1N.N1"."1N.N D Q STOP
- .S NUM=$E(REQST,4,5)+$P($P(DURA,"."),"L",2),NUM=$S(NUM<10:"0"_NUM,NUM<13:NUM,1:$S((NUM-12)<10:"0"_(NUM-12),1:(NUM-12))),DATE=$E(REQST,1,3)_NUM
- .S DAYS=$$DAY(DATE),STOP=$$SCH^XLFDT($P($P(DURA,"."),"L",2)_"M",$P(REQST,"."))_"."_$P(REQST,".",2),DEL=$P($P(DURA,"L",2),"."),STOP=$$FMADD^XLFDT(STOP,"",((DAYS*$P(DURA,DEL,2))*24))
- .I +$G(PRNTON),$G(SCHEDULE)]"" S STOP=$$STPADM(SCHEDULE,$G(ADMINS),STOP)
- I DURA["L" S STOP=$P($$SCH^XLFDT($P(DURA,"L",2)_"M",$P(REQST,".")),".")_"."_$P(REQST,".",2) D Q STOP
- .I +$G(PRNTON),$G(SCHEDULE)]"" S STOP=$$STPADM(SCHEDULE,$G(ADMINS),STOP)
- I DURA["W",DURA["." S DURA="H"_(($P(DURA,"W",2)*7)*24)
- I DURA["D",DURA["." S DURA="H"_($P(DURA,"D",2)*24)
- I +DURA=DURA,DURA["." S DURA="H"_(DURA*24)
- I DURA["'" S DURA="M"_$P(DURA,"'",2)
- S STOP=$$FMADD^XLFDT(REQST,$S(DURA["W":$P(DURA,"W",2)*7,DURA["D":$P(DURA,"D",2),+DURA=DURA:+DURA,1:""),$S(DURA["H":$P(DURA,"H",2),1:""),$S(DURA["M":$P(DURA,"M",2),1:""),$S(DURA["S":$P(DURA,"S",2),1:""))
- ;if complex order, calculate STOP DATE base on admin time; p*388
- I +$G(PRNTON),$G(SCHEDULE)]"",DURA'="" S STOP=$S((DURA["H")&'($P(DURA,"H",2)#24):$$STPADM(SCHEDULE,$G(ADMINS),STOP),"MH'"[$E(DURA,1):STOP,1:$$STPADM(SCHEDULE,$G(ADMINS),STOP))
- Q STOP
- ZQDATE(DATE,MONTHS) ;BUMP DATE BY A MONTH (OR SO)
- ;;
- S X=$E($P(DATE,"."),1,5)+($E($P(DATE,"."),4,5)>(12-MONTHS)*88+MONTHS)_$E($P(DATE,"."),6,7) F D ^%DT Q:Y>0 S X=X-1
- S NEWDATE=X_"."_$P(DATE,".",2)
- Q NEWDATE
- DAY(DATE) ;DATE=FIRST FIVE DIGITS OF FM DATE
- N X
- I DATE'?5N Q -1
- S X=$E(DATE,4,5) I X<1!(X>12) Q -1
- S X=DATE+1+(X=12*88)_"01"
- Q $E($$FMADD^XLFDT(X,-1),6,7)
- STPADM(SCH,AT,STP) ; calculate STOP DATE based on admin schedule; p*388
- ;SCH - Schedule, AT - Admin times, STP - Stop Date
- N X,Y,PSG,PND,ND,AT1
- S STP=+$FN(STP,"",4) S:SCH["PRN" AT=""
- I AT="" Q STP
- I AT?.N D Q AT1
- . S AT1=STP\1_"."_AT I $$FMDIFF^XLFDT(AT1,STP,2)<0 S AT1=$$FMADD^XLFDT(AT1,1) Q
- F Y=1:1 S AT1=$P(AT,"-",Y) Q:'AT1 S ND=STP\1_"."_AT1,PSG(+ND)=""
- S ND="" F S ND=$O(PSG(ND)) Q:'ND S X=$$FMDIFF^XLFDT(STP,ND,2) I X<1 S PND=ND Q
- I $D(PSG),$G(PND)="" Q $O(PSG(9999999),-1)
- Q $S($G(PND):PND,1:STP)
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSJHL9 10102 printed Feb 18, 2025@23:33:26 Page 2
- PSJHL9 ;BIR/LDT - VALIDATE INCOMING HL7 DATA/CREATE NEW ORDER ;Aug 26, 2020@15:04:51
- +1 ;;5.0;INPATIENT MEDICATIONS;**1,18,31,42,47,50,63,72,75,58,80,110,111,134,267,279,194,388,399**;16 DEC 97;Build 64
- +2 ;
- +3 ; Reference to ^PSDRUG is supported by DBIA# 2192.
- +4 ; Reference to ^PS(50.7 is supported by DBIA# 2180.
- +5 ; Reference to ^PS(51.2 is supported by DBIA# 2178.
- +6 ; Reference to ^PS(55 is supported by DBIA# 2191.
- +7 ; Reference to ^ORERR is supported by DBIA# 2187.
- +8 ; Reference to ^ORHLESC is supported by DBIA# 4922.
- +9 ;
- VALID ;
- +1 IF APPL=""
- IF PSITEM=""
- SET PSREASON="Missing or invalid Orderable Item"
- DO ERROR
- QUIT
- +2 IF PSITEM]""
- IF '$DATA(^PS(50.7,+PSITEM,0))
- SET PSREASON="Missing or invalid Orderable Item"
- DO ERROR
- QUIT
- +3 IF $GET(APPL)'["B"
- IF $GET(APPL)'["A"
- IF +$GET(ROUTE)'>0
- SET PSREASON="Missing or invalid Med Route"
- DO ERROR
- QUIT
- +4 SET APPL=$SELECT($GET(APPL)["B":"F",$GET(APPL)["A":"F",$GET(DISPENSE)]"":$$ORTYP(ROUTE,DISPENSE),1:$$TRYAGAIN(ROUTE,PSITEM))
- +5 if APPL=""
- SET APPL="IP"
- +6 IF APPL'="F"
- Begin DoDot:1
- +7 IF $GET(SCHEDULE)]""
- NEW X
- SET X=SCHEDULE
- Begin DoDot:2
- +8 ;*194 Allow multi-word schedules
- +9 IF X[""""!($ASCII(X)=45)!(X?.E1C.E)!($LENGTH(X," ")>$SELECT(X["PRN":4,1:3))!($LENGTH($PIECE(X,"@"))>70)!($LENGTH($PIECE(X,"@",2))>119)!($LENGTH(X)<1)!(X["P RN")!(X["PR N")
- SET X=""
- QUIT
- +10 IF X?.E1L.E
- SET X=$$ENLU^PSGMI(X)
- +11 SET X=$$TRIM^XLFSTR(X,"R"," ")
- +12 IF X["Q0"
- SET X=""
- QUIT
- End DoDot:2
- SET SCHEDULE=X
- +13 IF APPL["U"
- IF $GET(SCHEDULE)=""
- SET PSREASON="Missing or invalid schedule"
- DO ERROR
- QUIT
- +14 NEW DFN
- SET DFN=PSJHLDFN
- DO IN5^VADPT
- IF 'VAIP(5)
- if APPT=""
- Begin DoDot:2
- +15 IF APPL="UP"
- SET APPL="IN"
- QUIT
- +16 IF APPL="IP"
- SET APPL="IN"
- QUIT
- End DoDot:2
- IF APPL="UN"
- IF APPT=""
- SET PSREASON="Cannot place Unit Dose orders for an Outpatient"
- DO ERROR
- QUIT
- +17 IF $GET(ROC)'="R"
- IF $GET(ROUTE)'>0
- SET PSREASON="Missing or invalid Med Route"
- DO ERROR
- QUIT
- End DoDot:1
- +18 IF APPL="F"
- Begin DoDot:1
- +19 IF '$ORDER(^TMP("PSJNVO",$JOB,"SOL",0))&('$ORDER(^TMP("PSJNVO",$JOB,"AD",0)))
- SET PSREASON="IV Fluid orders must have at least one additive or solution"
- DO ERROR
- QUIT
- +20 ;Allow intermittent IV orders to have a null infusion rate.
- IF $GET(IVCAT)="I"
- IF $GET(INFRT)=""
- QUIT
- +21 IF $GET(INFRT)=""
- SET PSREASON="Invalid Infusion Rate"
- DO ERROR
- QUIT
- End DoDot:1
- +22 QUIT
- +23 ;
- 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)
- +2 DO EN1^PSJHLERR(PSJHLDFN,$SELECT(PSOC="XO":"UX",1:"OC"),$PIECE(ORDER,U),PSREASON)
- SET QFLG=1
- KILL ^TMP("PSJNVO",$JOB)
- +3 QUIT
- +4 ;
- NVO ; put new orders in non-verified orders file
- +1 IF '$DATA(ROUTE)
- SET ROUTE=""
- +2 IF $GET(ROUTE)=""
- if APPL="F"
- SET ROUTE=$ORDER(^PS(51.2,"B","INTRAVENOUS",0))
- +3 NEW DA,DR,DIE
- DO ENGNN^PSGOETO
- SET DIE="^PS(53.1,"
- +4 SET DR="1////"_PROVIDER_";3////"_$$ESC^ORHLESC(ROUTE)_";4////"_$EXTRACT(APPL)_";28////P"_";108////"_PSITEM_";27.1////"_LOGIN_";27////"_LOGIN_";.5////"_PSJHLDFN_";.24////"_PRIORITY_";125////"_$GET(PRNTON)
- +5 IF $GET(LOC)]""
- if $PIECE($GET(^SC(+LOC,0)),U,3)="C"
- SET DR=DR_";113////"_LOC_";126////"_$GET(APPT)
- +6 IF $GET(IVCAT)]""
- SET DR=DR_";128////"_IVCAT
- SET ADMINS=""
- +7 if $GET(SCHTYP)]""
- SET DR=DR_";7////"_SCHTYP
- +8 DO ^DIE
- KILL PSJHLSKP
- SET NEWORDER=DA
- SET PSJORDER=DA_"P"
- +9 SET $PIECE(^PS(55,PSJHLDFN,5.1),"^",2)=PROVIDER
- +10 if $GET(ORDER)]""
- SET $PIECE(^PS(53.1,DA,0),"^",21)=$PIECE(ORDER,"^")
- +11 if $GET(APPL)["P"
- SET $PIECE(^PS(53.1,DA,0),"^",13)=1
- +12 SET $PIECE(^PS(53.1,DA,0),"^",18)=DA
- +13 if $GET(ROC)]""
- SET $PIECE(^PS(53.1,DA,0),"^",24)=ROC
- +14 if $GET(PREON)]""
- SET $PIECE(^PS(53.1,DA,0),"^",25)=PREON
- +15 if $GET(ADMINS)
- SET $PIECE(^PS(53.1,DA,2),"^",5)=ADMINS
- +16 if $GET(REQST)]""
- SET $PIECE(^PS(53.1,DA,2.5),"^")=REQST
- +17 ; Transform duration units of doses to a for administrations
- +18 if $EXTRACT(DURATION,1,5)="doses"
- SET DURATION=$TRANSLATE(DURATION,"doses","a")
- +19 if $GET(DURATION)]""
- SET $PIECE(^PS(53.1,DA,2.5),"^",2)=DURATION
- +20 if $GET(IVLIMIT)]""
- SET $PIECE(^PS(53.1,DA,2.5),"^",4)=IVLIMIT
- +21 IF $GET(REQST)]""
- IF $GET(DURATION)]""
- SET $PIECE(^PS(53.1,DA,2.5),"^",3)=$$STOP(REQST,DURATION)
- +22 if $GET(INSTR)]""
- SET $PIECE(^PS(53.1,DA,.3),"^")=INSTR
- +23 IF $GET(INFRT)]""
- Begin DoDot:1
- +24 IF INFRT
- if (INFRT["Minutes"!(INFRT["Hours"))
- SET INFRT="INFUSE OVER "_INFRT
- +25 SET ^PS(53.1,DA,8)=IVTYP_"^^^^"_INFRT
- +26 IF INFRT["@"
- IF ($PIECE(INFRT,"@",2)?1.N)
- SET $PIECE(^PS(53.1,DA,17),"^")=$PIECE(INFRT,"@",2)
- End DoDot:1
- +27 if $GET(FREQ)]""
- SET $PIECE(^PS(53.1,DA,2),"^",6)=FREQ
- +28 if $GET(SCHTYP)]""
- SET $PIECE(^PS(53.1,DA,0),"^",7)=SCHTYP
- +29 IF $GET(APPL)'="I"
- IF $GET(INSTR)]""
- NEW X
- SET X=INSTR
- DO STRIP
- IF $SELECT(X?.E1C.E:0,$LENGTH(X)>60:0,X="":0,X["^":0,X?1.P:1,1:1)
- SET $PIECE(^PS(53.1,DA,.2),"^",2)=X
- SET $PIECE(^PS(53.1,DA,.2),"^",5,6)=$GET(DOSE)_"^"_$$UNESC^ORHLESC($GET(UNIT))
- +30 SET $PIECE(^PS(53.1,DA,.2),"^",3)=ORDCON
- +31 IF $GET(SCHEDULE)]""
- SET $PIECE(^PS(53.1,DA,2),"^")=$$UNESC^ORHLESC(SCHEDULE)
- +32 IF $GET(APPL)="I"
- IF $GET(UNITS)]""
- SET $PIECE(^PS(53.1,DA,.3),"^")=$$UNESC^ORHLESC(UNITS)
- +33 SET ^PS(53.1,DA,4)="^^^^^^"_CLERK
- +34 IF $GET(DISPENSE)
- SET ^PS(53.1,DA,1,0)="^53.11P^1^1"
- SET ^PS(53.1,DA,1,1,0)=DISPENSE_"^"_$$UNESC^ORHLESC(UNITS)
- SET ^PS(53.1,DA,1,"B",$EXTRACT(DISPENSE,1,30),1)=""
- +35 IF $DATA(PROCOM)
- Begin DoDot:1
- +36 IF '$DATA(^PS(53.1,DA,12,0))
- SET ^(0)="^53.1012^0^0"
- +37 SET JJ=0
- FOR
- SET JJ=$ORDER(PROCOM(JJ))
- if 'JJ
- QUIT
- SET $PIECE(^PS(53.1,DA,12,0),"^",3,4)=JJ_"^"_JJ
- SET ^PS(53.1,DA,12,JJ,0)=$$UNESC^ORHLESC(PROCOM(JJ))
- End DoDot:1
- +38 ;*399-IND
- SET ^PS(53.1,DA,18)=$$UNESC^ORHLESC(PSJINDI)
- +39 IF $DATA(ADMINSTR)
- Begin DoDot:1
- +40 IF '$DATA(^PS(53.1,DA,3,0))
- SET ^(0)="^53.12^0^0"
- +41 SET JJ=0
- FOR
- SET JJ=$ORDER(ADMINSTR(JJ))
- if 'JJ
- QUIT
- SET $PIECE(^PS(53.1,DA,3,0),"^",3,4)=JJ_"^"_JJ
- SET ^PS(53.1,DA,3,JJ,0)=ADMINSTR(JJ)
- End DoDot:1
- +42 IF $DATA(^TMP("PSJNVO",$JOB,"AD"))
- Begin DoDot:1
- +43 SET ^PS(53.1,DA,"AD",0)="^53.157PA^0^0"
- +44 SET JJ=0
- FOR
- SET JJ=$ORDER(^TMP("PSJNVO",$JOB,"AD",JJ))
- if 'JJ
- QUIT
- SET $PIECE(^PS(53.1,DA,"AD",0),"^",3,4)=JJ_"^"_JJ
- SET ^PS(53.1,DA,"AD",JJ,0)=^TMP("PSJNVO",$JOB,"AD",JJ,0)
- SET ^PS(53.1,DA,"AD","B",$$UNESC^ORHLESC($PIECE(^TMP("PSJNVO",$JOB,"AD",JJ,0),"^")),JJ)=""
- End DoDot:1
- +45 IF $DATA(^TMP("PSJNVO",$JOB,"SOL"))
- Begin DoDot:1
- +46 SET ^PS(53.1,DA,"SOL",0)="^53.158PA^0^0"
- +47 SET JJ=0
- FOR
- SET JJ=$ORDER(^TMP("PSJNVO",$JOB,"SOL",JJ))
- if 'JJ
- QUIT
- SET $PIECE(^PS(53.1,DA,"SOL",0),"^",3,4)=JJ_"^"_JJ
- SET ^PS(53.1,DA,"SOL",JJ,0)=^TMP("PSJNVO",$JOB,"SOL",JJ,0)
- SET ^PS(53.1,DA,"SOL","B",$PIECE(^TMP("PSJNVO",$JOB,"SOL",JJ,0),"^"),JJ)=""
- End DoDot:1
- +48 IF $ORDER(^TMP("PSJNVO",$JOB,10,0))
- Begin DoDot:1
- +49 SET ^PS(53.1,DA,10,0)="^53.1112A^0^0"
- +50 SET JJ=0
- FOR
- SET JJ=$ORDER(^TMP("PSJNVO",$JOB,10,JJ))
- if 'JJ
- QUIT
- SET $PIECE(^PS(53.1,DA,10,0),"^",3,4)=JJ_"^"_JJ
- SET ^PS(53.1,DA,10,JJ,0)=$$UNESC^ORHLESC(^TMP("PSJNVO",$JOB,10,JJ,0))
- SET ^PS(53.1,DA,10,"B",$$UNESC^ORHLESC($EXTRACT(^TMP("PSJNVO",$JOB,10,JJ,0),1,30)),JJ)=""
- Begin DoDot:2
- +51 SET ^PS(53.1,DA,10,JJ,1)=$PIECE($GET(^VA(200,+CLERK,0)),"^")
- +52 IF $ORDER(^TMP("PSJNVO",$JOB,10,JJ,2,0))
- SET ^PS(53.1,DA,10,JJ,2,0)="^53.11122^0^0"
- Begin DoDot:3
- +53 SET QQ=0
- FOR
- SET QQ=$ORDER(^TMP("PSJNVO",$JOB,10,JJ,2,QQ))
- if 'QQ
- QUIT
- SET $PIECE(^PS(53.1,DA,10,JJ,2,0),"^",3,4)=QQ_"^"_QQ
- SET ^PS(53.1,DA,10,JJ,2,QQ,0)=$$UNESC^ORHLESC(^TMP("PSJNVO",$JOB,10,JJ,2,QQ,0))
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +54 QUIT
- STRIP ;Strips spaces off the end of instructions.
- +1 IF $EXTRACT(X,$LENGTH(X))=" "
- FOR
- SET X=$EXTRACT(X,1,$LENGTH(X)-1)
- if $EXTRACT(X,$LENGTH(X))'=" "
- QUIT
- +2 QUIT
- +3 ;
- ORTYP(MDRT,DDRG) ;Entry point to determine order type for 53.1
- +1 ;MDRT=Med Route from 51.2, DDRG=Dispense Drug
- +2 IF '$GET(DDRG)
- SET ORTYP=""
- QUIT ORTYP
- +3 IF '$DATA(^PSDRUG(+DDRG,2))
- SET ORTYP=""
- QUIT ORTYP
- +4 IF $PIECE(^PSDRUG(DDRG,2),"^",3)'["I"
- IF $PIECE(^PSDRUG(DDRG,2),"^",3)'["U"
- SET ORTYP=""
- QUIT ORTYP
- +5 IF '$GET(MDRT)
- SET ORTYP=""
- QUIT ORTYP
- +6 IF '$DATA(^PS(51.2,+MDRT,0))
- SET ORTYP=""
- QUIT ORTYP
- +7 IF $PIECE(^PSDRUG(DDRG,2),"^",3)["I"
- IF $PIECE(^PSDRUG(DDRG,2),"^",3)'["U"
- IF $PIECE(^PS(51.2,MDRT,0),"^",6)=1
- SET ORTYP="IN"
- QUIT ORTYP
- +8 IF $PIECE(^PSDRUG(DDRG,2),"^",3)'["I"
- IF $PIECE(^PS(51.2,MDRT,0),"^",6)=1
- SET ORTYP="UP"
- QUIT ORTYP
- +9 IF $PIECE(^PSDRUG(DDRG,2),"^",3)["I"
- IF $PIECE(^PS(51.2,MDRT,0),"^",6)=1
- SET ORTYP="IP"
- QUIT ORTYP
- +10 IF $PIECE(^PSDRUG(DDRG,2),"^",3)["I"
- IF $PIECE(^PSDRUG(DDRG,2),"^",3)'["U"
- IF $PIECE(^PS(51.2,MDRT,0),"^",6)'=1
- SET ORTYP="IP"
- QUIT ORTYP
- +11 IF $PIECE(^PSDRUG(DDRG,2),"^",3)["U"
- IF $PIECE(^PSDRUG(DDRG,2),"^",3)'["I"
- IF $PIECE(^PS(51.2,MDRT,0),"^",6)'=1
- SET ORTYP="UN"
- QUIT ORTYP
- +12 IF $PIECE(^PSDRUG(DDRG,2),"^",3)["U"
- IF $PIECE(^PS(51.2,MDRT,0),"^",6)'=1
- SET ORTYP="UP"
- QUIT ORTYP
- +13 SET ORTYP=""
- QUIT ORTYP
- +14 ;
- TRYAGAIN(MDRT,OI) ;
- +1 ;MDRT=Med Route from 51.2, OI=Orderable Item
- +2 NEW ORTYPI,ORTYPU,ORTYPP
- +3 SET ORTYP=""
- SET ORTYPI=0
- SET ORTYPU=0
- SET ORTYPP=0
- +4 NEW DDRG
- SET DDRG=0
- FOR
- SET DDRG=$ORDER(^PSDRUG("ASP",OI,DDRG))
- if 'DDRG
- QUIT
- Begin DoDot:1
- +5 IF $GET(^PSDRUG(DDRG,"I"))]""
- if ^PSDRUG(DDRG,"I")'>DT
- QUIT
- +6 SET ORTYP=$$ORTYP(MDRT,DDRG)
- Begin DoDot:2
- +7 IF ORTYP["I"
- SET ORTYPI=ORTYPI+1
- +8 IF ORTYP["U"
- SET ORTYPU=ORTYPU+1
- +9 IF ORTYP["P"
- SET ORTYPP=ORTYPP+1
- End DoDot:2
- End DoDot:1
- +10 SET ORTYP=$SELECT(ORTYPU>ORTYPI:"U",1:"I")
- SET ORTYP=ORTYP_$SELECT(ORTYPP>0:"P",1:"N")
- +11 QUIT ORTYP
- +12 ;
- STOP(REQST,DURA) ;
- +1 ;REQST=Requested start date, DURA=Duration from CPRS
- +2 IF DURA["L"
- IF DURA?1A1".".N
- SET DAYS=$$DAY($EXTRACT(REQST,1,5))
- SET DURA="H"_((DAYS*$PIECE(DURA,"L",2))*24)
- +3 IF DURA["L"
- IF DURA?1A.1N.N1"."1N.N
- Begin DoDot:1
- +4 SET NUM=$EXTRACT(REQST,4,5)+$PIECE($PIECE(DURA,"."),"L",2)
- SET NUM=$SELECT(NUM<10:"0"_NUM,NUM<13:NUM,1:$SELECT((NUM-12)<10:"0"_(NUM-12),1:(NUM-12)))
- SET DATE=$EXTRACT(REQST,1,3)_NUM
- +5 SET DAYS=$$DAY(DATE)
- SET STOP=$$SCH^XLFDT($PIECE($PIECE(DURA,"."),"L",2)_"M",$PIECE(REQST,"."))_"."_$PIECE(REQST,".",2)
- SET DEL=$PIECE($PIECE(DURA,"L",2),".")
- SET STOP=$$FMADD^XLFDT(STOP,"",((DAYS*$PIECE(DURA,DEL,2))*24))
- +6 IF +$GET(PRNTON)
- IF $GET(SCHEDULE)]""
- SET STOP=$$STPADM(SCHEDULE,$GET(ADMINS),STOP)
- End DoDot:1
- QUIT STOP
- +7 IF DURA["L"
- SET STOP=$PIECE($$SCH^XLFDT($PIECE(DURA,"L",2)_"M",$PIECE(REQST,".")),".")_"."_$PIECE(REQST,".",2)
- Begin DoDot:1
- +8 IF +$GET(PRNTON)
- IF $GET(SCHEDULE)]""
- SET STOP=$$STPADM(SCHEDULE,$GET(ADMINS),STOP)
- End DoDot:1
- QUIT STOP
- +9 IF DURA["W"
- IF DURA["."
- SET DURA="H"_(($PIECE(DURA,"W",2)*7)*24)
- +10 IF DURA["D"
- IF DURA["."
- SET DURA="H"_($PIECE(DURA,"D",2)*24)
- +11 IF +DURA=DURA
- IF DURA["."
- SET DURA="H"_(DURA*24)
- +12 IF DURA["'"
- SET DURA="M"_$PIECE(DURA,"'",2)
- +13 SET STOP=$$FMADD^XLFDT(REQST,$SELECT(DURA["W":$PIECE(DURA,"W",2)*7,DURA["D":$PIECE(DURA,"D",2),+DURA=DURA:+DURA,1:""),$SELECT(DURA["H":$PIECE(DURA,"H",2),1:""),$SELECT(DURA["M":$PIECE(DURA,"M",2),1:""),$SELECT(DURA["S":$PIECE(DURA,"S",2),1:""))
- +14 ;if complex order, calculate STOP DATE base on admin time; p*388
- +15 IF +$GET(PRNTON)
- IF $GET(SCHEDULE)]""
- IF DURA'=""
- SET STOP=$SELECT((DURA["H")&'($PIECE(DURA,"H",2)#24):$$STPADM(SCHEDULE,$GET(ADMINS),STOP),"MH'"[$EXTRACT(DURA,1):STOP,1:$$STPADM(SCHEDULE,$GET(ADMINS),STOP))
- +16 QUIT STOP
- ZQDATE(DATE,MONTHS) ;BUMP DATE BY A MONTH (OR SO)
- +1 ;;
- +2 SET X=$EXTRACT($PIECE(DATE,"."),1,5)+($EXTRACT($PIECE(DATE,"."),4,5)>(12-MONTHS)*88+MONTHS)_$EXTRACT($PIECE(DATE,"."),6,7)
- FOR
- DO ^%DT
- if Y>0
- QUIT
- SET X=X-1
- +3 SET NEWDATE=X_"."_$PIECE(DATE,".",2)
- +4 QUIT NEWDATE
- DAY(DATE) ;DATE=FIRST FIVE DIGITS OF FM DATE
- +1 NEW X
- +2 IF DATE'?5N
- QUIT -1
- +3 SET X=$EXTRACT(DATE,4,5)
- IF X<1!(X>12)
- QUIT -1
- +4 SET X=DATE+1+(X=12*88)_"01"
- +5 QUIT $EXTRACT($$FMADD^XLFDT(X,-1),6,7)
- STPADM(SCH,AT,STP) ; calculate STOP DATE based on admin schedule; p*388
- +1 ;SCH - Schedule, AT - Admin times, STP - Stop Date
- +2 NEW X,Y,PSG,PND,ND,AT1
- +3 SET STP=+$FNUMBER(STP,"",4)
- if SCH["PRN"
- SET AT=""
- +4 IF AT=""
- QUIT STP
- +5 IF AT?.N
- Begin DoDot:1
- +6 SET AT1=STP\1_"."_AT
- IF $$FMDIFF^XLFDT(AT1,STP,2)<0
- SET AT1=$$FMADD^XLFDT(AT1,1)
- QUIT
- End DoDot:1
- QUIT AT1
- +7 FOR Y=1:1
- SET AT1=$PIECE(AT,"-",Y)
- if 'AT1
- QUIT
- SET ND=STP\1_"."_AT1
- SET PSG(+ND)=""
- +8 SET ND=""
- FOR
- SET ND=$ORDER(PSG(ND))
- if 'ND
- QUIT
- SET X=$$FMDIFF^XLFDT(STP,ND,2)
- IF X<1
- SET PND=ND
- QUIT
- +9 IF $DATA(PSG)
- IF $GET(PND)=""
- QUIT $ORDER(PSG(9999999),-1)
- +10 QUIT $SELECT($GET(PND):PND,1:STP)