- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/INPATIENT_MEDICATIONS-PSJ-PSIV-PSG--PSGW/PSJHL9.m
r613 r623 1 PSJHL9 ;BIR/LDT-VALIDATE INCOMING HL7 DATA/CREATE NEW ORDER ;08 Jul 99 / 10:50 AM 2 ;;5.0; INPATIENT MEDICATIONS ;**1,18,31,42,47,50,63,72,75,58,80,110,111,134**;16 DEC 97;Build 124 3 ; 4 ; Reference to ^PSDRUG is supported by DBIA# 2192. 5 ; Reference to ^PS(50.7 is supported by DBIA# 2180. 6 ; Reference to ^PS(51.2 is supported by DBIA# 2178. 7 ; Reference to ^PS(55 is supported by DBIA# 2191. 8 ; Reference to ^ORERR is supported by DBIA# 2187. 9 ; Reference to ^ORHLESC is supported by DBIA# 4922. 10 ; 11 VALID ; 12 I APPL="",PSITEM="" S PSREASON="Missing or invalid Orderable Item" D ERROR Q 13 I PSITEM]"",'$D(^PS(50.7,+PSITEM,0)) S PSREASON="Missing or invalid Orderable Item" D ERROR Q 14 I $G(APPL)'["B",$G(APPL)'["A",+$G(ROUTE)'>0 S PSREASON="Missing or invalid Med Route" D ERROR Q 15 S APPL=$S($G(APPL)["B":"F",$G(APPL)["A":"F",$G(DISPENSE)]"":$$ORTYP(ROUTE,DISPENSE),1:$$TRYAGAIN(ROUTE,PSITEM)) 16 S:APPL="" APPL="IP" 17 I APPL'="F" D 18 .I $G(SCHEDULE)]"" N X S X=SCHEDULE D S SCHEDULE=X 19 ..I X[""""!($A(X)=45)!(X?.E1C.E)!($L(X," ")>3)!($L($P(X,"@"))>70)!($L($P(X,"@",2))>119)!($L(X)<1)!(X["P RN")!(X["PR N") S X="" Q 20 ..I X?.E1L.E S X=$$ENLU^PSGMI(X) 21 ..S X=$$TRIM^XLFSTR(X,"R"," ") 22 ..I X["Q0" S X="" Q 23 .I APPL["U",$G(SCHEDULE)="" S PSREASON="Missing or invalid schedule" D ERROR Q 24 .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 25 .. I APPL="UP" S APPL="IN" Q 26 .. I APPL="IP" S APPL="IN" Q 27 .I $G(ROC)'="R",$G(ROUTE)'>0 S PSREASON="Missing or invalid Med Route" D ERROR Q 28 I APPL="F" D 29 .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 30 .I $G(IVCAT)="I",$G(INFRT)="" Q ;Allow intermittent IV orders to have a null infusion rate. 31 .I $G(INFRT)="" S PSREASON="Invalid Infusion Rate" D ERROR Q 32 Q 33 ; 34 ERROR ;Sends error msg to CPRS, logs error in OE/RR Errors file 35 S X="ORERR" X ^%ZOSF("TEST") I D EN^ORERR(PSREASON,.PSJMSG) 36 D EN1^PSJHLERR(PSJHLDFN,$S(PSOC="XO":"UX",1:"OC"),$P(ORDER,U),PSREASON) S QFLG=1 K ^TMP("PSJNVO",$J) 37 Q 38 ; 39 NVO ; put new orders in non-verified orders file 40 I '$D(ROUTE) S ROUTE="" 41 I $G(ROUTE)="" S:APPL="F" ROUTE=$O(^PS(51.2,"B","INTRAVENOUS",0)) 42 N DA,DR,DIE D ENGNN^PSGOETO S DIE="^PS(53.1," 43 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) 44 I $G(LOC)]"" S:$P($G(^SC(+LOC,0)),U,3)="C" DR=DR_";113////"_LOC_";126////"_$G(APPT) 45 I $G(IVCAT)]"" S DR=DR_";128////"_IVCAT S ADMINS="" 46 S:$G(SCHTYP)]"" DR=DR_";7////"_SCHTYP 47 D ^DIE K PSJHLSKP S NEWORDER=DA,PSJORDER=DA_"P" 48 S $P(^PS(55,PSJHLDFN,5.1),"^",2)=PROVIDER 49 S:$G(ORDER)]"" $P(^PS(53.1,DA,0),"^",21)=$P(ORDER,"^") 50 S:$G(APPL)["P" $P(^PS(53.1,DA,0),"^",13)=1 51 S $P(^PS(53.1,DA,0),"^",18)=DA 52 S:$G(ROC)]"" $P(^PS(53.1,DA,0),"^",24)=ROC 53 S:$G(PREON)]"" $P(^PS(53.1,DA,0),"^",25)=PREON 54 S:$G(ADMINS) $P(^PS(53.1,DA,2),"^",5)=ADMINS 55 S:$G(REQST)]"" $P(^PS(53.1,DA,2.5),"^")=REQST 56 ; Transform duration units of doses to a for administrations 57 S:$E(DURATION,1,5)="doses" DURATION=$TR(DURATION,"doses","a") 58 S:$G(DURATION)]"" $P(^PS(53.1,DA,2.5),"^",2)=DURATION 59 S:$G(IVLIMIT)]"" $P(^PS(53.1,DA,2.5),"^",4)=IVLIMIT 60 I $G(REQST)]"",$G(DURATION)]"" S $P(^PS(53.1,DA,2.5),"^",3)=$$STOP(REQST,DURATION) 61 S:$G(INSTR)]"" $P(^PS(53.1,DA,.3),"^")=INSTR 62 I $G(INFRT)]"" D 63 .I INFRT S:(INFRT["Minutes"!(INFRT["Hours")) INFRT="INFUSE OVER "_INFRT 64 .S ^PS(53.1,DA,8)=IVTYP_"^^^^"_INFRT 65 S:$G(FREQ)]"" $P(^PS(53.1,DA,2),"^",6)=FREQ 66 S:$G(SCHTYP)]"" $P(^PS(53.1,DA,0),"^",7)=SCHTYP 67 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)) 68 S $P(^PS(53.1,DA,.2),"^",3)=ORDCON 69 I $G(SCHEDULE)]"" S $P(^PS(53.1,DA,2),"^")=$$UNESC^ORHLESC(SCHEDULE) 70 I $G(APPL)="I" I $G(UNITS)]"" S $P(^PS(53.1,DA,.3),"^")=$$UNESC^ORHLESC(UNITS) 71 S ^PS(53.1,DA,4)="^^^^^^"_CLERK 72 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)="" 73 I $D(PROCOM) D 74 .I '$D(^PS(53.1,DA,12,0)) S ^(0)="^53.1012^0^0" 75 .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)) 76 I $D(ADMINSTR) D 77 .I '$D(^PS(53.1,DA,3,0)) S ^(0)="^53.12^0^0" 78 .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) 79 I $D(^TMP("PSJNVO",$J,"AD")) D 80 .S ^PS(53.1,DA,"AD",0)="^53.157PA^0^0" 81 .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)="" 82 I $D(^TMP("PSJNVO",$J,"SOL")) D 83 .S ^PS(53.1,DA,"SOL",0)="^53.158PA^0^0" 84 .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)="" 85 I $O(^TMP("PSJNVO",$J,10,0)) D 86 .S ^PS(53.1,DA,10,0)="^53.1112A^0^0" 87 .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 88 ..S ^PS(53.1,DA,10,JJ,1)=$P($G(^VA(200,+CLERK,0)),"^") 89 ..I $O(^TMP("PSJNVO",$J,10,JJ,2,0)) S ^PS(53.1,DA,10,JJ,2,0)="^53.11122^0^0" D 90 ...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)) 91 Q 92 STRIP ;Strips spaces off the end of instructions. 93 I $E(X,$L(X))=" " F S X=$E(X,1,$L(X)-1) Q:$E(X,$L(X))'=" " 94 Q 95 ; 96 ORTYP(MDRT,DDRG) ;Entry point to determine order type for 53.1 97 ;MDRT=Med Route from 51.2, DDRG=Dispense Drug 98 I '$G(DDRG) S ORTYP="" Q ORTYP 99 I '$D(^PSDRUG(+DDRG,2)) S ORTYP="" Q ORTYP 100 I $P(^PSDRUG(DDRG,2),"^",3)'["I",$P(^PSDRUG(DDRG,2),"^",3)'["U" S ORTYP="" Q ORTYP 101 I '$G(MDRT) S ORTYP="" Q ORTYP 102 I '$D(^PS(51.2,+MDRT,0)) S ORTYP="" Q ORTYP 103 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 104 I $P(^PSDRUG(DDRG,2),"^",3)'["I",$P(^PS(51.2,MDRT,0),"^",6)=1 S ORTYP="UP" Q ORTYP 105 I $P(^PSDRUG(DDRG,2),"^",3)["I",$P(^PS(51.2,MDRT,0),"^",6)=1 S ORTYP="IP" Q ORTYP 106 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 107 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 108 I $P(^PSDRUG(DDRG,2),"^",3)["U",$P(^PS(51.2,MDRT,0),"^",6)'=1 S ORTYP="UP" Q ORTYP 109 S ORTYP="" Q ORTYP 110 ; 111 TRYAGAIN(MDRT,OI) ; 112 ;MDRT=Med Route from 51.2, OI=Orderable Item 113 N ORTYPI,ORTYPU,ORTYPP 114 S ORTYP="",ORTYPI=0,ORTYPU=0,ORTYPP=0 115 N DDRG S DDRG=0 F S DDRG=$O(^PSDRUG("ASP",OI,DDRG)) Q:'DDRG D 116 .I $G(^PSDRUG(DDRG,"I"))]"" Q:^PSDRUG(DDRG,"I")'>DT 117 .S ORTYP=$$ORTYP(MDRT,DDRG) D 118 ..I ORTYP["I" S ORTYPI=ORTYPI+1 119 ..I ORTYP["U" S ORTYPU=ORTYPU+1 120 ..I ORTYP["P" S ORTYPP=ORTYPP+1 121 S ORTYP=$S(ORTYPU>ORTYPI:"U",1:"I") S ORTYP=ORTYP_$S(ORTYPP>0:"P",1:"N") 122 Q ORTYP 123 ; 124 STOP(REQST,DURA) ; 125 ;REQST=Requested start date, DURA=Duration from CPRS 126 I DURA["L",DURA?1A1".".N S DAYS=$$DAY($E(REQST,1,5)),DURA="H"_((DAYS*$P(DURA,"L",2))*24) 127 I DURA["L",DURA?1A.1N.N1"."1N.N D Q STOP 128 .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 129 .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)) 130 I DURA["L" S STOP=$P($$SCH^XLFDT($P(DURA,"L",2)_"M",$P(REQST,".")),".")_"."_$P(REQST,".",2) Q STOP 131 I DURA["W",DURA["." S DURA="H"_(($P(DURA,"W",2)*7)*24) 132 I DURA["D",DURA["." S DURA="H"_($P(DURA,"D",2)*24) 133 I +DURA=DURA,DURA["." S DURA="H"_(DURA*24) 134 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:"")) 135 Q STOP 136 ZQDATE(DATE,MONTHS) ;BUMP DATE BY A MONTH (OR SO) 137 ;; 138 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 139 S NEWDATE=X_"."_$P(DATE,".",2) 140 Q NEWDATE 141 DAY(DATE) ;DATE=FIRST FIVE DIGITS OF FM DATE 142 N X 143 I DATE'?5N Q -1 144 S X=$E(DATE,4,5) I X<1!(X>12) Q -1 145 S X=DATE+1+(X=12*88)_"01" 146 Q $E($$FMADD^XLFDT(X,-1),6,7) 1 PSJHL9 ;BIR/LDT-VALIDATE INCOMING HL7 DATA/CREATE NEW ORDER ;08 Jul 99 / 10:50 AM 2 ;;5.0; INPATIENT MEDICATIONS ;**1,18,31,42,47,50,63,72,75,58,80,110,111**;16 DEC 97 3 ; 4 ; Reference to ^PSDRUG is supported by DBIA# 2192. 5 ; Reference to ^PS(50.7 is supported by DBIA# 2180. 6 ; Reference to ^PS(51.2 is supported by DBIA# 2178. 7 ; Reference to ^PS(55 is supported by DBIA# 2191. 8 ; Reference to ^ORERR is supported by DBIA# 2187. 9 ; 10 VALID ; 11 I APPL="",PSITEM="" S PSREASON="Missing or invalid Orderable Item" D ERROR Q 12 I PSITEM]"",'$D(^PS(50.7,+PSITEM,0)) S PSREASON="Missing or invalid Orderable Item" D ERROR Q 13 I $G(APPL)'["B",$G(APPL)'["A",+$G(ROUTE)'>0 S PSREASON="Missing or invalid Med Route" D ERROR Q 14 S APPL=$S($G(APPL)["B":"F",$G(APPL)["A":"F",$G(DISPENSE)]"":$$ORTYP(ROUTE,DISPENSE),1:$$TRYAGAIN(ROUTE,PSITEM)) 15 S:APPL="" APPL="IP" 16 I APPL'="F" D 17 .I $G(SCHEDULE)]"" N X S X=SCHEDULE D S SCHEDULE=X 18 ..I X[""""!($A(X)=45)!(X?.E1C.E)!($L(X," ")>3)!($L(X)>70)!($L(X)<1)!(X["P RN")!(X["PR N") S X="" Q 19 ..I X?.E1L.E S X=$$ENLU^PSGMI(X) 20 ..S X=$$TRIM^XLFSTR(X,"R"," ") 21 ..I X["Q0" S X="" Q 22 .I APPL["U",$G(SCHEDULE)="" S PSREASON="Missing or invalid schedule" D ERROR Q 23 .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 24 .. I APPL="UP" S APPL="IN" Q 25 .. I APPL="IP" S APPL="IN" Q 26 .I $G(ROC)'="R",$G(ROUTE)'>0 S PSREASON="Missing or invalid Med Route" D ERROR Q 27 I APPL="F" D 28 .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 29 .I $G(INFRT)="" S PSREASON="Invalid Infusion Rate" D ERROR Q 30 Q 31 ; 32 ERROR ;Sends error msg to CPRS, logs error in OE/RR Errors file 33 S X="ORERR" X ^%ZOSF("TEST") I D EN^ORERR(PSREASON,.PSJMSG) 34 D EN1^PSJHLERR(PSJHLDFN,$S(PSOC="XO":"UX",1:"OC"),$P(ORDER,U),PSREASON) S QFLG=1 K ^TMP("PSJNVO",$J) 35 Q 36 ; 37 NVO ; put new orders in non-verified orders file 38 I '$D(ROUTE) S ROUTE="" 39 S:APPL="F" ROUTE=$O(^PS(51.2,"B","INTRAVENOUS",0)) 40 N DA,DR,DIE D ENGNN^PSGOETO S DIE="^PS(53.1," 41 S DR="1////"_PROVIDER_";3////"_ROUTE_";4////"_$E(APPL)_";28////P"_";108////"_PSITEM_";27.1////"_LOGIN_";27////"_LOGIN_";.5////"_PSJHLDFN_";.24////"_PRIORITY_";125////"_$G(PRNTON) 42 I $G(LOC)]"" S:$P($G(^SC(+LOC,0)),U,3)="C" DR=DR_";113////"_LOC_";126////"_$G(APPT) 43 D ^DIE K PSJHLSKP S NEWORDER=DA,PSJORDER=DA_"P" 44 S $P(^PS(55,PSJHLDFN,5.1),"^",2)=PROVIDER 45 S:$G(ORDER)]"" $P(^PS(53.1,DA,0),"^",21)=$P(ORDER,"^") 46 S:$G(APPL)["P" $P(^PS(53.1,DA,0),"^",13)=1 47 S $P(^PS(53.1,DA,0),"^",18)=DA 48 S:$G(ROC)]"" $P(^PS(53.1,DA,0),"^",24)=ROC 49 S:$G(PREON)]"" $P(^PS(53.1,DA,0),"^",25)=PREON 50 S:$G(REQST)]"" $P(^PS(53.1,DA,2.5),"^")=REQST 51 S:$G(DURATION)]"" $P(^PS(53.1,DA,2.5),"^",2)=DURATION 52 S:$G(IVLIMIT)]"" $P(^PS(53.1,DA,2.5),"^",4)=IVLIMIT 53 I $G(REQST)]"",$G(DURATION)]"" S $P(^PS(53.1,DA,2.5),"^",3)=$$STOP(REQST,DURATION) 54 S:$G(INSTR)]"" $P(^PS(53.1,DA,.3),"^")=INSTR 55 S:$G(INFRT)]"" ^PS(53.1,DA,8)=IVTYP_"^^^^"_INFRT 56 S:$G(FREQ)]"" $P(^PS(53.1,DA,2),"^",6)=FREQ 57 S:$G(SCHTYP)]"" $P(^PS(53.1,DA,0),"^",7)=SCHTYP 58 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)_"^"_$G(UNIT) 59 S $P(^PS(53.1,DA,.2),"^",3)=ORDCON 60 I $G(SCHEDULE)]"" S ^PS(53.1,DA,2)=SCHEDULE 61 I $G(APPL)="I" I $G(UNITS)]"" S $P(^PS(53.1,DA,.3),"^")=UNITS 62 S ^PS(53.1,DA,4)="^^^^^^"_CLERK 63 I $G(DISPENSE) S ^PS(53.1,DA,1,0)="^53.11P^1^1",^PS(53.1,DA,1,1,0)=DISPENSE_"^"_UNITS,^PS(53.1,DA,1,"B",$E(DISPENSE,1,30),1)="" 64 I $D(PROCOM) D 65 .I '$D(^PS(53.1,DA,12,0)) S ^(0)="^53.1012^0^0" 66 .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)=PROCOM(JJ) 67 I $D(ADMINSTR) D 68 .I '$D(^PS(53.1,DA,3,0)) S ^(0)="^53.12^0^0" 69 .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) 70 I $D(^TMP("PSJNVO",$J,"AD")) D 71 .S ^PS(53.1,DA,"AD",0)="^53.157PA^0^0" 72 .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",$P(^TMP("PSJNVO",$J,"AD",JJ,0),"^"),JJ)="" 73 I $D(^TMP("PSJNVO",$J,"SOL")) D 74 .S ^PS(53.1,DA,"SOL",0)="^53.158PA^0^0" 75 .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)="" 76 I $O(^TMP("PSJNVO",$J,10,0)) D 77 .S ^PS(53.1,DA,10,0)="^53.1112A^0^0" 78 .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)=^TMP("PSJNVO",$J,10,JJ,0),^PS(53.1,DA,10,"B",$E(^TMP("PSJNVO",$J,10,JJ,0),1,30),JJ)="" D 79 ..S ^PS(53.1,DA,10,JJ,1)=$P($G(^VA(200,+CLERK,0)),"^") 80 ..I $O(^TMP("PSJNVO",$J,10,JJ,2,0)) S ^PS(53.1,DA,10,JJ,2,0)="^53.11122^0^0" D 81 ...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)=^TMP("PSJNVO",$J,10,JJ,2,QQ,0) 82 Q 83 STRIP ;Strips spaces off the end of instructions. 84 I $E(X,$L(X))=" " F S X=$E(X,1,$L(X)-1) Q:$E(X,$L(X))'=" " 85 Q 86 ; 87 ORTYP(MDRT,DDRG) ;Entry point to determine order type for 53.1 88 ;MDRT=Med Route from 51.2, DDRG=Dispense Drug 89 I $P(^PSDRUG(DDRG,2),"^",3)'["I",$P(^PSDRUG(DDRG,2),"^",3)'["U" S ORTYP="" Q ORTYP 90 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 91 I $P(^PSDRUG(DDRG,2),"^",3)'["I",$P(^PS(51.2,MDRT,0),"^",6)=1 S ORTYP="UP" Q ORTYP 92 I $P(^PSDRUG(DDRG,2),"^",3)["I",$P(^PS(51.2,MDRT,0),"^",6)=1 S ORTYP="IP" Q ORTYP 93 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 94 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 95 I $P(^PSDRUG(DDRG,2),"^",3)["U",$P(^PS(51.2,MDRT,0),"^",6)'=1 S ORTYP="UP" Q ORTYP 96 S ORTYP="" Q ORTYP 97 ; 98 TRYAGAIN(MDRT,OI) ; 99 ;MDRT=Med Route from 51.2, OI=Orderable Item 100 N ORTYPI,ORTYPU,ORTYPP 101 S ORTYP="",ORTYPI=0,ORTYPU=0,ORTYPP=0 102 N DDRG S DDRG=0 F S DDRG=$O(^PSDRUG("ASP",OI,DDRG)) Q:'DDRG D 103 .I $G(^PSDRUG(DDRG,"I"))]"" Q:^PSDRUG(DDRG,"I")'>DT 104 .S ORTYP=$$ORTYP(MDRT,DDRG) D 105 ..I ORTYP["I" S ORTYPI=ORTYPI+1 106 ..I ORTYP["U" S ORTYPU=ORTYPU+1 107 ..I ORTYP["P" S ORTYPP=ORTYPP+1 108 S ORTYP=$S(ORTYPU>ORTYPI:"U",1:"I") S ORTYP=ORTYP_$S(ORTYPP>0:"P",1:"N") 109 Q ORTYP 110 ; 111 STOP(REQST,DURA) ; 112 ;REQST=Requested start date, DURA=Duration from CPRS 113 I DURA["L",DURA?1A1".".N S DAYS=$$DAY($E(REQST,1,5)),DURA="H"_((DAYS*$P(DURA,"L",2))*24) 114 I DURA["L",DURA?1A.1N.N1"."1N.N D Q STOP 115 .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 116 .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)) 117 I DURA["L" S STOP=$P($$SCH^XLFDT($P(DURA,"L",2)_"M",$P(REQST,".")),".")_"."_$P(REQST,".",2) Q STOP 118 I DURA["W",DURA["." S DURA="H"_(($P(DURA,"W",2)*7)*24) 119 I DURA["D",DURA["." S DURA="H"_($P(DURA,"D",2)*24) 120 I +DURA=DURA,DURA["." S DURA="H"_(DURA*24) 121 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:"")) 122 Q STOP 123 ZQDATE(DATE,MONTHS) ;BUMP DATE BY A MONTH (OR SO) 124 ;; 125 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 126 S NEWDATE=X_"."_$P(DATE,".",2) 127 Q NEWDATE 128 DAY(DATE) ;DATE=FIRST FIVE DIGITS OF FM DATE 129 N X 130 I DATE'?5N Q -1 131 S X=$E(DATE,4,5) I X<1!(X>12) Q -1 132 S X=DATE+1+(X=12*88)_"01" 133 Q $E($$FMADD^XLFDT(X,-1),6,7)
Note:
See TracChangeset
for help on using the changeset viewer.