ECXUTL6 ;ALB/JRC - Utilities for DSS Extracts ;4/8/19 11:11
;;3.0;DSS EXTRACTS;**92,105,112,119,132,154,170,173,174**;Dec 22, 1997;Build 33
;
NUTKEY(P,D) ;Generate n&fs feeder key
;Required variables
; p - diet type production diet, standing orders, supplemental
; feedings, or tube feedings.
; d - diet ien from files 116.2, 118.3, 118, or 118.2
;Check input
I $G(P)=""!'$G(D) Q ""
;Init variables
N PRO,IENS,CODE,DIET
S (PRO,IENS,CODE,DIET)=0
S PRO=$O(^ECX(728.45,"B",P,PRO))
S CODE=D_$S(P="PD":";FH(116.2,",P="SO":";FH(118.3,",P="SF":";FH(118,",P="TF":";FH(118.2,",1:"")
S DIET=0,DIET=$O(^ECX(728.45,+PRO,1,"B",CODE,DIET))
S IENS=""_DIET_","_PRO_","_""
Q $$GET1^DIQ(728.451,IENS,1)
;
NUTLOC(P,D,FPD,FDD,FPF,DLT,DFL) ;Define nutrition fields
;Required variables
; p - patient status, inpatient or outpatient
;
; d - diet type production diet, standing orders, supplemental
; feedings, or tube feedings.
; Output: food production division, food delivery division, food
; production facility, food delivery type, delivery feeder
; location
;Init variables
N WARD,TRSVP,CRSVP,OPLOC,MASWARD
S (CRSVP,TRSVP)=0,(WARD,DLT,DFL,MASWARD)=""
S OPLOC=""
;Check input
I $G(P)=""!($G(D)="")!'($G(FHDFN)) Q ""
;Get food production facility for inpatient, use 115.1.13 (dietetic
;ward) field which points 119.6 (nutrition location), field 3 (tray
;service point) or field 4 (cafeteria service point), which points to
;119.72 (production facility) field 2.
I P="INP" D
.N VAHOW
.K ^UTILITY("VAIP",$J)
.S DFN=$P($G(^FHPT(FHDFN,0)),U,3)
.S VAIP("D")=$G(SDATE),VAHOW=2
.D IN5^VADPT
.S MASWARD=+^UTILITY("VAIP",$J,5)
.S WARD=$O(^FH(119.6,"AW",+MASWARD,0))
.S:+WARD'>0 WARD=""
.S TRSVP=$$GET1^DIQ(119.6,WARD,3,"I")
.S CRSVP=$$GET1^DIQ(119.6,WARD,4,"I")
.;Get divisions
.D GETDIV
.Q
;
;Get food production facility for OP Supplemental feedings,
;use 115.1.13 (dietetic
;ward) field which points 119.6 (nutrition location), field 3 (tray
;service point) or field 4 (cafeteria service point), which points to
;119.72 (production facility) field 2.
I P["OP",D["SF" D
.S OPLOC=""_$P(^TMP($J,"FH",DATE,FHDFN,NUMBER,"RM"),U,3)_","_""
.S TRSVP=$$GET1^DIQ(119.6,OPLOC,3,"I")
.;Get delivery division
.D GETDIV
.Q
;Get food production facility for OP Standing Orders,
;use 115.1.13 (dietetic
;ward) field which points 119.6 (nutrition location), field 3 (tray
;service point) or field 4 (cafeteria service point), which points to
;119.72 (production facility) field 2.
I P["OP",D["SO" D
.S OPLOC=""_$P(^TMP($J,"FH",DATE,FHDFN,NUMBER,"RM"),U,3)_","_""
.S TRSVP=$$GET1^DIQ(119.6,OPLOC,3,"I")
.;Get delivery division
.D GETDIV
.Q
;Get food production facility for outpatient recurring meal, use
;115.16.2 (outpatient location) which points to file 119.6 (nutrition
;location) field 3 (tray service point) or field 4 (cafeteria service
;point), which points to 119.72 (production facility) field 2.
I P["OP",D["RM" D
.S OPLOC=""_$P(NODE,U,3)_","_"",TRSVP=$$GET1^DIQ(119.6,OPLOC,3,"I")
.D GETDIV
.Q
;
;Get food production facility for outpatient tube feeding, use
;115.16.2 (outpatient location) then use 119.6 nutrition location
;which points to 119.72 field 2.
I P["OP",D["TF" D
.S OPLOC=""_$P(^TMP($J,"FH",DATE,FHDFN,NUMBER,"RM"),U,3)_","_""
.S TRSVP=$$GET1^DIQ(119.6,OPLOC,3,"I")
.;Get delivery division
.D GETDIV
.Q
;
;Get food production facility for special meals, use 115.17.2
;location field 2 which is a pointer to 119.6 (nutrition location)
;which points to 119.72 via field 2 (tray service point) which points
;to file 119.71 (production facility) field 2.
I P["OP",D["SM" D
.S OPLOC=""_$P(NODE,U,3)_","_""
.S TRSVP=$$GET1^DIQ(119.6,OPLOC,3,"I")
.;Get delivery division
.D GETDIV
.Q
;
;Get food production facility for outpatient guest meals, use
;115.18.4 (outpatient location) then use 119.6 nutrition location
;which points to 119.72 (production facility) field 2.
I P["OP",D["GM" D
.S OPLOC=""_$P(NODE,U,5)_","_"",TRSVP=$$GET1^DIQ(119.6,OPLOC,3,"I")
.S FPF=$$GET1^DIQ(119.72,""_TRSVP_","_"",2,"I")
.;Get delivery division
.D GETDIV
.Q
;
;Get delivery location type for patients; with inpatients the type of
;service needs to be pulled from the admission node, with outpatients
;the type of service needs to be pulled from different nodes and use
;field 101 of Nutrition Location file (#119.6). Delivery location
;types only set for the following meals:
; Inpatient with a production diet
; Outpatient with a recurring meal
; Outpatient with a special meal
; Outpatient with a guest meal
; all other meals are null
I P="INP",D="PD" D
.S DLT=$P($G(NODE),U,8)
I P="OP",((D="RM")!(D="SM")) D
.S DLT=$E($$GET1^DIQ(119.6,""_$P(NODE,U,3)_","_"",101,"E"),1)
I P="OP",D="GM" D
.S DLT=$E($$GET1^DIQ(119.6,""_$P(NODE,U,5)_","_"",101,"E"),1)
;
;Delivery feeder location
I DLT="C" D
.S DFL=$E($$GET1^DIQ(119.6,WARD,4,"E"),1,10)
.S IEN=$$GET1^DIQ(119.72,+CRSVP,2,"I")
.S IEN=""_IEN_";FH(119.71,"
.S FPF=$O(^ECX(728.46,"B",IEN,FPF))
.S FPF=$E($$GET1^DIQ(728.46,FPF,.01,"E"),1,10)
I (DLT["T")!(DLT["D") D
.I P="INP" D
..S DFL=$$GET1^DIQ(42,+MASWARD,44,"I")
.I P="OP" D
..S DFL=$O(^FH(119.6,+OPLOC,"L","B",0))
I (DLT=""),"SFTFSO"[D D
.S DFL=$S(TRSVP:$$GET1^DIQ(119.6,+WARD,3,"E"),1:$$GET1^DIQ(119.6,+WARD,4,"E"))
Q 1
;
GETDIV ;Get divisions and food production facility
;Init variables
N IEN,SIEN,SVP
S (FDD,FPF,FPD)=""
S SVP=$S(TRSVP:TRSVP,CRSVP:CRSVP,1:"")
S IEN=$$GET1^DIQ(119.72,+SVP,2,"I")
Q:'IEN
;Get delivery division
S SIEN=""_+SVP_";FH(119.72,"
S FDD=$O(^ECX(728.46,"B",SIEN,FDD))
S FDD=""_$$GET1^DIQ(728.46,FDD,1,"I")_","_""
S FDD=$$GET1^DIQ(4,FDD,99,"E")
;Get production division and food production facility
S IEN=""_IEN_";FH(119.71,"
S FPF=$O(^ECX(728.46,"B",IEN,FPF))
S FPD=""_$$GET1^DIQ(728.46,FPF,1,"I")_","_""
S FPD=$$GET1^DIQ(4,FPD,99,"E")
S FPF=$E($$GET1^DIQ(728.46,FPF,.01,"E"),1,10)
Q
;
SUR(CRST,STCD,CLINIC) ;Surgery stop codes and clinic (outpatients only)
;Quit if not outpatient
I ECXA="I" Q ;174 Only set stop code, credit stop, and clinic if patient is an outpatient
S CLINIC=$S($P(EC0,U,21):$P(EC0,U,21),$P(ECNO,U,2):$P(ECNO,U,2),1:$$GET1^DIQ(137.45,$P(EC0,U,4),2,"I")) ;174 Set clinic to associated clinic or non-OR location or surgical specialty's associated clinic
;Next, get stop code from file 728.44, if not found get it from file 44, if not found default to 435 if it's a non-OR procedure, otherwise 429
S STCD=$P($G(^ECX(728.44,+CLINIC,0)),U,4) S:STCD="" STCD=$$GET1^DIQ(40.7,$$GET1^DIQ(44,+CLINIC,8,"I"),1,"E") S:STCD="" STCD=$S($P(ECNO,U)="Y":435,1:429) ;174
S CRST=$P($G(^ECX(728.44,+CLINIC,0)),U,5) S:CRST="" CRST=$$GET1^DIQ(40.7,$$GET1^DIQ(44,+CLINIC,2503,"I"),1,"E") ;174 Set credit stop code to value in 728.44 else from file 44
Q
;
SURPODX(PRODX,PODX1,PODX2,PODX3,PODX4,PODX5) ;Get postop diagnosis codes
;Init variables
N CODE,I,PODX
S (PRODX,PODX1,PODX2,PODX3,PODX4,PODX5)="",CODE=0
;Check input
Q:'$D(DATAOP) 0
;Get principal postop dx code
I $P(DATAOP,U,3)'="" S PRODX=$$CODEC^ICDEX(80,$P(DATAOP,U,3)) ;154
;Get other postop dx codes
S (CODE,I)=0 F S CODE=$O(^SRO(136,ECD0,4,CODE)) Q:'CODE Q:I>5 D
.S I=I+1,PODX="PODX"_I I $P(^SRO(136,ECD0,4,CODE,0),U)'="" S @PODX=$$CODEC^ICDEX(80,$P(^SRO(136,ECD0,4,CODE,0),U)) ;154
Q 1
;
LOINC(ARRAY) ;Get DSS lab test information out of DSS LOINC CODE (#727.29) file
;Input
; ARRAY(LOINC-CK) := array of valid LOINC (#727.29 DSS LOINC CODE)
; entries with their check digit
; or,
; ARRAY("ALL") := request for all LOINC entries
;Output
; ^TMP($J,"EXCUTL6",LOINC-CK) =
; zero node of file 727.29 pieces 1 thru 4
; piece 1 := LOINC-CK (LOINC-check digit)
; piece 2 := DSS lar test number
; piece 3 := DSS test name
; piece 4 := DSS Reporting units
; piece 5 := LOINC name
; piece 6 := pointer to LAB LOINC (#95.3) code entry
; (delimited by "^")
; -1 := not a valid loinc entry from file 727.29
; -2 := no dss lar test number associated with loinc
;
; ^TMP($J,"ECXUTL6",LOINC-CK,WKLD,SPEC/-or-"DEFAULT",LTEST)=
; piece 1 := WKLD Code (external)
; piece 2 := specimen (external) or "DEFAULT LOINC"
; piece 3 := laboratory test (external)
; piece 4:= local LOINC code external
; (delimited by "^")
;
;
I '$D(ARRAY) Q
K ^TMP($J,"ECXUTL6")
N LOINCCK,LIEN,SPEC,EC0,WKLD,WKLD0,TA,LRASSV,LOINCPTR,LTEST,LLNC,LLNCP,SPECD
S LOINCCK=""
I $D(ARRAY("ALL")) D
. F S LOINCCK=$O(^ECX(727.29,"B",LOINCCK)) Q:'LOINCCK D EXT
E D
. F S LOINCCK=$O(ARRAY(LOINCCK)) Q:'LOINCCK D EXT
Q
;
EXT I '$D(^ECX(727.29,"B",LOINCCK)) S ^TMP($J,"ECXUTL6",LOINCCK)=-1_"^no entry in DSS LOINC CODE (#727.29)." Q
S LIEN=$O(^ECX(727.29,"B",LOINCCK,0))
I '$P(^ECX(727.29,LIEN,0),U,2) S ^TMP($J,"ECXUTL6",LOINCCK)=-2_"^no dss test number found." Q
S EC0=^ECX(727.29,LIEN,0)
S ^TMP($J,"ECXUTL6",LOINCCK)=EC0_"^"
S LOINCPTR=""
;**Lexicon LOINC Code - test whether LEX*2*75 installed.
; Else, get directly from file #95.3
S X="LEXLR" X ^%ZOSF("TEST") I '$T D
. I LOINCCK=$$GET1^DIQ(95.3,$P(LOINCCK,"-"),.01) D
. . S LOINCPTR=$$GET1^DIQ(95.3,$P(LOINCCK,"-"),.01,"I")
S X="LEXLR" X ^%ZOSF("TEST") I $T D
. S LOINCPTR=$$CHKCODE^LEXLR(LOINCCK) ;DBIA5547
;**
I LOINCPTR D
. S ^TMP($J,"ECXUTL6",LOINCCK)=^TMP($J,"ECXUTL6",LOINCCK)_LOINCPTR
. S WKLD=0 F S WKLD=$O(^LAM("AI",LOINCPTR,WKLD)) Q:'WKLD D
. . S SPEC=0 F S SPEC=$O(^LAM("AI",LOINCPTR,WKLD,SPEC)) Q:'SPEC D
. . . S TA=0
. . . F S TA=$O(^LAM(WKLD,5,SPEC,1,TA)) Q:'TA D
. . . . S SPECD=^LAM(WKLD,5,SPEC,1,TA,0)
. . . . S LTEST=$P(SPECD,"^",4)
. . . . I LTEST,($P($G(^LAB(60,LTEST,64)),"^",2)=WKLD),($$GET1^DIQ(60,LTEST,3,"I")'="N") D
. . . . . S ^TMP($J,"ECXUTL6",LOINCCK,WKLD,SPEC,LTEST)=$$GET1^DIQ(64,WKLD,.01)_"^"_$$GET1^DIQ(61,SPEC,.01)_"^"_$$GET1^DIQ(60,LTEST,.01)_"^"_LOINCCK
Q
;
INPUTT ;
N DIC S DIC="^DIC(40.7,",DIC(0)="EMZ",DIC("S")="I '$P(^(0),U,3)&($L($P(^(0),U,2)'=3)) Q"
D ^DIC K:Y<0 X Q:Y<0
S X=$S($D(Y(0)):$P(Y(0),U,2),1:"") K:X=""!($L(X)'=3) X K DIC
Q
;
ISASIH(MVMT,TYPE) ;170 Section added to determine if patient is ASIH other facility at movement date/time
N ASIH,VAIP,DFN
S ASIH=0
S:TYPE=2 VAIP("E")=MVMT
S:TYPE=3 VAIP("D")=$$FMADD^XLFDT($P(^DGPM(MVMT,0),U),,,,-1)
S DFN=$P($G(^DGPM(MVMT,0)),U,3)
D IN5^VADPT
I "^43^45^46^"[("^"_+VAIP(4)_"^") S ASIH=1
Q ASIH
;
NEEDADR(TYPE,MVMT,EXTRACT) ;170 Section added to determine if an admission or discharge record for the ASIH other facility episode of care is needed
N REC,VAIP,DFN,NEXTMO ;173
S NEXTMO=$$NEXTMO(ECED) ;173 Get year/month for next month
S REC=1
S VAIP("E")=MVMT
S DFN=$P($G(^DGPM(MVMT,0)),U,3)
D IN5^VADPT
I TYPE="TRAN"&(EXTRACT="ADM") I "^43^45^46^"[("^"_$P($G(VAIP(15,3)),U)_"^") S REC=0
I TYPE="TRAN"&(EXTRACT="MOV") D ;173
.I $G(VAIP(16))="" S REC=0 S ^XTMP("ECXMOV",NEXTMO,MVMT)="" Q ;173 If there isn't a "next" movement, save it for next month
.I $P($G(VAIP(16,1)),U)'>ECSD S REC=0 Q ;173 Don't create a record if it's before the extract start date
.I $P($G(VAIP(16,1)),U)'>ECED I "^43^45^46^"[("^"_$P($G(VAIP(16,3)),U)_"^")!(+$G(VAIP(16,2))'=2) S REC=0 Q ;173 If next movement in timeframe and it's not continuing ASIH or a discharge then create a record
.I $P($G(VAIP(16,1)),U)>ECED S REC=0 I $$ECXYM^ECXUTL($P($G(VAIP(16,1)),U))>$$ECXYM^ECXUTL(ECED) S ^XTMP("ECXMOV",NEXTMO,MVMT)="" ;173 If next movement is after extract end date and is in the next month, save it
I TYPE="DIS" I "^43^45^46^"'[("^"_$P($G(VAIP(15,3)),U)_"^") S REC=0
Q REC_"^"_$S(REC&(EXTRACT="MOV")&(TYPE="TRAN"):$G(VAIP(16)),REC:MVMT,1:"")
;
NEXTMO(DATE) ;173 Given a date, determine the following month and return in year_month format (ex. 201811 for 11/2018)
N NEXT,DTSTR
S NEXT=""
Q:DATE="" NEXT
S DTSTR=$E(DATE,1,5)_"01" ;Set DTSTR to first of the month
S DTSTR=$$FMADD^XLFDT(DTSTR,32) ;Get date 32 days from the 1st of the previous month
S DTSTR=$$FMADD^XLFDT(DTSTR,-($E(DTSTR,6,7))) ;Subtract number of days into next month to get the last day of the previous month
S DTSTR=$$FMADD^XLFDT(DTSTR,1) ;Add one day to get first day of next month
S NEXT=$$ECXYM^ECXUTL(DTSTR) ;Convert FM date to year_month format
Q NEXT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECXUTL6 12731 printed Sep 23, 2025@19:30:32 Page 2
ECXUTL6 ;ALB/JRC - Utilities for DSS Extracts ;4/8/19 11:11
+1 ;;3.0;DSS EXTRACTS;**92,105,112,119,132,154,170,173,174**;Dec 22, 1997;Build 33
+2 ;
NUTKEY(P,D) ;Generate n&fs feeder key
+1 ;Required variables
+2 ; p - diet type production diet, standing orders, supplemental
+3 ; feedings, or tube feedings.
+4 ; d - diet ien from files 116.2, 118.3, 118, or 118.2
+5 ;Check input
+6 IF $GET(P)=""!'$GET(D)
QUIT ""
+7 ;Init variables
+8 NEW PRO,IENS,CODE,DIET
+9 SET (PRO,IENS,CODE,DIET)=0
+10 SET PRO=$ORDER(^ECX(728.45,"B",P,PRO))
+11 SET CODE=D_$SELECT(P="PD":";FH(116.2,",P="SO":";FH(118.3,",P="SF":";FH(118,",P="TF":";FH(118.2,",1:"")
+12 SET DIET=0
SET DIET=$ORDER(^ECX(728.45,+PRO,1,"B",CODE,DIET))
+13 SET IENS=""_DIET_","_PRO_","_""
+14 QUIT $$GET1^DIQ(728.451,IENS,1)
+15 ;
NUTLOC(P,D,FPD,FDD,FPF,DLT,DFL) ;Define nutrition fields
+1 ;Required variables
+2 ; p - patient status, inpatient or outpatient
+3 ;
+4 ; d - diet type production diet, standing orders, supplemental
+5 ; feedings, or tube feedings.
+6 ; Output: food production division, food delivery division, food
+7 ; production facility, food delivery type, delivery feeder
+8 ; location
+9 ;Init variables
+10 NEW WARD,TRSVP,CRSVP,OPLOC,MASWARD
+11 SET (CRSVP,TRSVP)=0
SET (WARD,DLT,DFL,MASWARD)=""
+12 SET OPLOC=""
+13 ;Check input
+14 IF $GET(P)=""!($GET(D)="")!'($GET(FHDFN))
QUIT ""
+15 ;Get food production facility for inpatient, use 115.1.13 (dietetic
+16 ;ward) field which points 119.6 (nutrition location), field 3 (tray
+17 ;service point) or field 4 (cafeteria service point), which points to
+18 ;119.72 (production facility) field 2.
+19 IF P="INP"
Begin DoDot:1
+20 NEW VAHOW
+21 KILL ^UTILITY("VAIP",$JOB)
+22 SET DFN=$PIECE($GET(^FHPT(FHDFN,0)),U,3)
+23 SET VAIP("D")=$GET(SDATE)
SET VAHOW=2
+24 DO IN5^VADPT
+25 SET MASWARD=+^UTILITY("VAIP",$JOB,5)
+26 SET WARD=$ORDER(^FH(119.6,"AW",+MASWARD,0))
+27 if +WARD'>0
SET WARD=""
+28 SET TRSVP=$$GET1^DIQ(119.6,WARD,3,"I")
+29 SET CRSVP=$$GET1^DIQ(119.6,WARD,4,"I")
+30 ;Get divisions
+31 DO GETDIV
+32 QUIT
End DoDot:1
+33 ;
+34 ;Get food production facility for OP Supplemental feedings,
+35 ;use 115.1.13 (dietetic
+36 ;ward) field which points 119.6 (nutrition location), field 3 (tray
+37 ;service point) or field 4 (cafeteria service point), which points to
+38 ;119.72 (production facility) field 2.
+39 IF P["OP"
IF D["SF"
Begin DoDot:1
+40 SET OPLOC=""_$PIECE(^TMP($JOB,"FH",DATE,FHDFN,NUMBER,"RM"),U,3)_","_""
+41 SET TRSVP=$$GET1^DIQ(119.6,OPLOC,3,"I")
+42 ;Get delivery division
+43 DO GETDIV
+44 QUIT
End DoDot:1
+45 ;Get food production facility for OP Standing Orders,
+46 ;use 115.1.13 (dietetic
+47 ;ward) field which points 119.6 (nutrition location), field 3 (tray
+48 ;service point) or field 4 (cafeteria service point), which points to
+49 ;119.72 (production facility) field 2.
+50 IF P["OP"
IF D["SO"
Begin DoDot:1
+51 SET OPLOC=""_$PIECE(^TMP($JOB,"FH",DATE,FHDFN,NUMBER,"RM"),U,3)_","_""
+52 SET TRSVP=$$GET1^DIQ(119.6,OPLOC,3,"I")
+53 ;Get delivery division
+54 DO GETDIV
+55 QUIT
End DoDot:1
+56 ;Get food production facility for outpatient recurring meal, use
+57 ;115.16.2 (outpatient location) which points to file 119.6 (nutrition
+58 ;location) field 3 (tray service point) or field 4 (cafeteria service
+59 ;point), which points to 119.72 (production facility) field 2.
+60 IF P["OP"
IF D["RM"
Begin DoDot:1
+61 SET OPLOC=""_$PIECE(NODE,U,3)_","_""
SET TRSVP=$$GET1^DIQ(119.6,OPLOC,3,"I")
+62 DO GETDIV
+63 QUIT
End DoDot:1
+64 ;
+65 ;Get food production facility for outpatient tube feeding, use
+66 ;115.16.2 (outpatient location) then use 119.6 nutrition location
+67 ;which points to 119.72 field 2.
+68 IF P["OP"
IF D["TF"
Begin DoDot:1
+69 SET OPLOC=""_$PIECE(^TMP($JOB,"FH",DATE,FHDFN,NUMBER,"RM"),U,3)_","_""
+70 SET TRSVP=$$GET1^DIQ(119.6,OPLOC,3,"I")
+71 ;Get delivery division
+72 DO GETDIV
+73 QUIT
End DoDot:1
+74 ;
+75 ;Get food production facility for special meals, use 115.17.2
+76 ;location field 2 which is a pointer to 119.6 (nutrition location)
+77 ;which points to 119.72 via field 2 (tray service point) which points
+78 ;to file 119.71 (production facility) field 2.
+79 IF P["OP"
IF D["SM"
Begin DoDot:1
+80 SET OPLOC=""_$PIECE(NODE,U,3)_","_""
+81 SET TRSVP=$$GET1^DIQ(119.6,OPLOC,3,"I")
+82 ;Get delivery division
+83 DO GETDIV
+84 QUIT
End DoDot:1
+85 ;
+86 ;Get food production facility for outpatient guest meals, use
+87 ;115.18.4 (outpatient location) then use 119.6 nutrition location
+88 ;which points to 119.72 (production facility) field 2.
+89 IF P["OP"
IF D["GM"
Begin DoDot:1
+90 SET OPLOC=""_$PIECE(NODE,U,5)_","_""
SET TRSVP=$$GET1^DIQ(119.6,OPLOC,3,"I")
+91 SET FPF=$$GET1^DIQ(119.72,""_TRSVP_","_"",2,"I")
+92 ;Get delivery division
+93 DO GETDIV
+94 QUIT
End DoDot:1
+95 ;
+96 ;Get delivery location type for patients; with inpatients the type of
+97 ;service needs to be pulled from the admission node, with outpatients
+98 ;the type of service needs to be pulled from different nodes and use
+99 ;field 101 of Nutrition Location file (#119.6). Delivery location
+100 ;types only set for the following meals:
+101 ; Inpatient with a production diet
+102 ; Outpatient with a recurring meal
+103 ; Outpatient with a special meal
+104 ; Outpatient with a guest meal
+105 ; all other meals are null
+106 IF P="INP"
IF D="PD"
Begin DoDot:1
+107 SET DLT=$PIECE($GET(NODE),U,8)
End DoDot:1
+108 IF P="OP"
IF ((D="RM")!(D="SM"))
Begin DoDot:1
+109 SET DLT=$EXTRACT($$GET1^DIQ(119.6,""_$PIECE(NODE,U,3)_","_"",101,"E"),1)
End DoDot:1
+110 IF P="OP"
IF D="GM"
Begin DoDot:1
+111 SET DLT=$EXTRACT($$GET1^DIQ(119.6,""_$PIECE(NODE,U,5)_","_"",101,"E"),1)
End DoDot:1
+112 ;
+113 ;Delivery feeder location
+114 IF DLT="C"
Begin DoDot:1
+115 SET DFL=$EXTRACT($$GET1^DIQ(119.6,WARD,4,"E"),1,10)
+116 SET IEN=$$GET1^DIQ(119.72,+CRSVP,2,"I")
+117 SET IEN=""_IEN_";FH(119.71,"
+118 SET FPF=$ORDER(^ECX(728.46,"B",IEN,FPF))
+119 SET FPF=$EXTRACT($$GET1^DIQ(728.46,FPF,.01,"E"),1,10)
End DoDot:1
+120 IF (DLT["T")!(DLT["D")
Begin DoDot:1
+121 IF P="INP"
Begin DoDot:2
+122 SET DFL=$$GET1^DIQ(42,+MASWARD,44,"I")
End DoDot:2
+123 IF P="OP"
Begin DoDot:2
+124 SET DFL=$ORDER(^FH(119.6,+OPLOC,"L","B",0))
End DoDot:2
End DoDot:1
+125 IF (DLT="")
IF "SFTFSO"[D
Begin DoDot:1
+126 SET DFL=$SELECT(TRSVP:$$GET1^DIQ(119.6,+WARD,3,"E"),1:$$GET1^DIQ(119.6,+WARD,4,"E"))
End DoDot:1
+127 QUIT 1
+128 ;
GETDIV ;Get divisions and food production facility
+1 ;Init variables
+2 NEW IEN,SIEN,SVP
+3 SET (FDD,FPF,FPD)=""
+4 SET SVP=$SELECT(TRSVP:TRSVP,CRSVP:CRSVP,1:"")
+5 SET IEN=$$GET1^DIQ(119.72,+SVP,2,"I")
+6 if 'IEN
QUIT
+7 ;Get delivery division
+8 SET SIEN=""_+SVP_";FH(119.72,"
+9 SET FDD=$ORDER(^ECX(728.46,"B",SIEN,FDD))
+10 SET FDD=""_$$GET1^DIQ(728.46,FDD,1,"I")_","_""
+11 SET FDD=$$GET1^DIQ(4,FDD,99,"E")
+12 ;Get production division and food production facility
+13 SET IEN=""_IEN_";FH(119.71,"
+14 SET FPF=$ORDER(^ECX(728.46,"B",IEN,FPF))
+15 SET FPD=""_$$GET1^DIQ(728.46,FPF,1,"I")_","_""
+16 SET FPD=$$GET1^DIQ(4,FPD,99,"E")
+17 SET FPF=$EXTRACT($$GET1^DIQ(728.46,FPF,.01,"E"),1,10)
+18 QUIT
+19 ;
SUR(CRST,STCD,CLINIC) ;Surgery stop codes and clinic (outpatients only)
+1 ;Quit if not outpatient
+2 ;174 Only set stop code, credit stop, and clinic if patient is an outpatient
IF ECXA="I"
QUIT
+3 ;174 Set clinic to associated clinic or non-OR location or surgical specialty's associated clinic
SET CLINIC=$SELECT($PIECE(EC0,U,21):$PIECE(EC0,U,21),$PIECE(ECNO,U,2):$PIECE(ECNO,U,2),1:$$GET1^DIQ(137.45,$PIECE(EC0,U,4),2,"I"))
+4 ;Next, get stop code from file 728.44, if not found get it from file 44, if not found default to 435 if it's a non-OR procedure, otherwise 429
+5 ;174
SET STCD=$PIECE($GET(^ECX(728.44,+CLINIC,0)),U,4)
if STCD=""
SET STCD=$$GET1^DIQ(40.7,$$GET1^DIQ(44,+CLINIC,8,"I"),1,"E")
if STCD=""
SET STCD=$SELECT($PIECE(ECNO,U)="Y":435,1:429)
+6 ;174 Set credit stop code to value in 728.44 else from file 44
SET CRST=$PIECE($GET(^ECX(728.44,+CLINIC,0)),U,5)
if CRST=""
SET CRST=$$GET1^DIQ(40.7,$$GET1^DIQ(44,+CLINIC,2503,"I"),1,"E")
+7 QUIT
+8 ;
SURPODX(PRODX,PODX1,PODX2,PODX3,PODX4,PODX5) ;Get postop diagnosis codes
+1 ;Init variables
+2 NEW CODE,I,PODX
+3 SET (PRODX,PODX1,PODX2,PODX3,PODX4,PODX5)=""
SET CODE=0
+4 ;Check input
+5 if '$DATA(DATAOP)
QUIT 0
+6 ;Get principal postop dx code
+7 ;154
IF $PIECE(DATAOP,U,3)'=""
SET PRODX=$$CODEC^ICDEX(80,$PIECE(DATAOP,U,3))
+8 ;Get other postop dx codes
+9 SET (CODE,I)=0
FOR
SET CODE=$ORDER(^SRO(136,ECD0,4,CODE))
if 'CODE
QUIT
if I>5
QUIT
Begin DoDot:1
+10 ;154
SET I=I+1
SET PODX="PODX"_I
IF $PIECE(^SRO(136,ECD0,4,CODE,0),U)'=""
SET @PODX=$$CODEC^ICDEX(80,$PIECE(^SRO(136,ECD0,4,CODE,0),U))
End DoDot:1
+11 QUIT 1
+12 ;
LOINC(ARRAY) ;Get DSS lab test information out of DSS LOINC CODE (#727.29) file
+1 ;Input
+2 ; ARRAY(LOINC-CK) := array of valid LOINC (#727.29 DSS LOINC CODE)
+3 ; entries with their check digit
+4 ; or,
+5 ; ARRAY("ALL") := request for all LOINC entries
+6 ;Output
+7 ; ^TMP($J,"EXCUTL6",LOINC-CK) =
+8 ; zero node of file 727.29 pieces 1 thru 4
+9 ; piece 1 := LOINC-CK (LOINC-check digit)
+10 ; piece 2 := DSS lar test number
+11 ; piece 3 := DSS test name
+12 ; piece 4 := DSS Reporting units
+13 ; piece 5 := LOINC name
+14 ; piece 6 := pointer to LAB LOINC (#95.3) code entry
+15 ; (delimited by "^")
+16 ; -1 := not a valid loinc entry from file 727.29
+17 ; -2 := no dss lar test number associated with loinc
+18 ;
+19 ; ^TMP($J,"ECXUTL6",LOINC-CK,WKLD,SPEC/-or-"DEFAULT",LTEST)=
+20 ; piece 1 := WKLD Code (external)
+21 ; piece 2 := specimen (external) or "DEFAULT LOINC"
+22 ; piece 3 := laboratory test (external)
+23 ; piece 4:= local LOINC code external
+24 ; (delimited by "^")
+25 ;
+26 ;
+27 IF '$DATA(ARRAY)
QUIT
+28 KILL ^TMP($JOB,"ECXUTL6")
+29 NEW LOINCCK,LIEN,SPEC,EC0,WKLD,WKLD0,TA,LRASSV,LOINCPTR,LTEST,LLNC,LLNCP,SPECD
+30 SET LOINCCK=""
+31 IF $DATA(ARRAY("ALL"))
Begin DoDot:1
+32 FOR
SET LOINCCK=$ORDER(^ECX(727.29,"B",LOINCCK))
if 'LOINCCK
QUIT
DO EXT
End DoDot:1
+33 IF '$TEST
Begin DoDot:1
+34 FOR
SET LOINCCK=$ORDER(ARRAY(LOINCCK))
if 'LOINCCK
QUIT
DO EXT
End DoDot:1
+35 QUIT
+36 ;
EXT IF '$DATA(^ECX(727.29,"B",LOINCCK))
SET ^TMP($JOB,"ECXUTL6",LOINCCK)=-1_"^no entry in DSS LOINC CODE (#727.29)."
QUIT
+1 SET LIEN=$ORDER(^ECX(727.29,"B",LOINCCK,0))
+2 IF '$PIECE(^ECX(727.29,LIEN,0),U,2)
SET ^TMP($JOB,"ECXUTL6",LOINCCK)=-2_"^no dss test number found."
QUIT
+3 SET EC0=^ECX(727.29,LIEN,0)
+4 SET ^TMP($JOB,"ECXUTL6",LOINCCK)=EC0_"^"
+5 SET LOINCPTR=""
+6 ;**Lexicon LOINC Code - test whether LEX*2*75 installed.
+7 ; Else, get directly from file #95.3
+8 SET X="LEXLR"
XECUTE ^%ZOSF("TEST")
IF '$TEST
Begin DoDot:1
+9 IF LOINCCK=$$GET1^DIQ(95.3,$PIECE(LOINCCK,"-"),.01)
Begin DoDot:2
+10 SET LOINCPTR=$$GET1^DIQ(95.3,$PIECE(LOINCCK,"-"),.01,"I")
End DoDot:2
End DoDot:1
+11 SET X="LEXLR"
XECUTE ^%ZOSF("TEST")
IF $TEST
Begin DoDot:1
+12 ;DBIA5547
SET LOINCPTR=$$CHKCODE^LEXLR(LOINCCK)
End DoDot:1
+13 ;**
+14 IF LOINCPTR
Begin DoDot:1
+15 SET ^TMP($JOB,"ECXUTL6",LOINCCK)=^TMP($JOB,"ECXUTL6",LOINCCK)_LOINCPTR
+16 SET WKLD=0
FOR
SET WKLD=$ORDER(^LAM("AI",LOINCPTR,WKLD))
if 'WKLD
QUIT
Begin DoDot:2
+17 SET SPEC=0
FOR
SET SPEC=$ORDER(^LAM("AI",LOINCPTR,WKLD,SPEC))
if 'SPEC
QUIT
Begin DoDot:3
+18 SET TA=0
+19 FOR
SET TA=$ORDER(^LAM(WKLD,5,SPEC,1,TA))
if 'TA
QUIT
Begin DoDot:4
+20 SET SPECD=^LAM(WKLD,5,SPEC,1,TA,0)
+21 SET LTEST=$PIECE(SPECD,"^",4)
+22 IF LTEST
IF ($PIECE($GET(^LAB(60,LTEST,64)),"^",2)=WKLD)
IF ($$GET1^DIQ(60,LTEST,3,"I")'="N")
Begin DoDot:5
+23 SET ^TMP($JOB,"ECXUTL6",LOINCCK,WKLD,SPEC,LTEST)=$$GET1^DIQ(64,WKLD,.01)_"^"_$$GET1^DIQ(61,SPEC,.01)_"^"_$$GET1^DIQ(60,LTEST,.01)_"^"_LOINCCK
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+24 QUIT
+25 ;
INPUTT ;
+1 NEW DIC
SET DIC="^DIC(40.7,"
SET DIC(0)="EMZ"
SET DIC("S")="I '$P(^(0),U,3)&($L($P(^(0),U,2)'=3)) Q"
+2 DO ^DIC
if Y<0
KILL X
if Y<0
QUIT
+3 SET X=$SELECT($DATA(Y(0)):$PIECE(Y(0),U,2),1:"")
if X=""!($LENGTH(X)'=3)
KILL X
KILL DIC
+4 QUIT
+5 ;
ISASIH(MVMT,TYPE) ;170 Section added to determine if patient is ASIH other facility at movement date/time
+1 NEW ASIH,VAIP,DFN
+2 SET ASIH=0
+3 if TYPE=2
SET VAIP("E")=MVMT
+4 if TYPE=3
SET VAIP("D")=$$FMADD^XLFDT($PIECE(^DGPM(MVMT,0),U),,,,-1)
+5 SET DFN=$PIECE($GET(^DGPM(MVMT,0)),U,3)
+6 DO IN5^VADPT
+7 IF "^43^45^46^"[("^"_+VAIP(4)_"^")
SET ASIH=1
+8 QUIT ASIH
+9 ;
NEEDADR(TYPE,MVMT,EXTRACT) ;170 Section added to determine if an admission or discharge record for the ASIH other facility episode of care is needed
+1 ;173
NEW REC,VAIP,DFN,NEXTMO
+2 ;173 Get year/month for next month
SET NEXTMO=$$NEXTMO(ECED)
+3 SET REC=1
+4 SET VAIP("E")=MVMT
+5 SET DFN=$PIECE($GET(^DGPM(MVMT,0)),U,3)
+6 DO IN5^VADPT
+7 IF TYPE="TRAN"&(EXTRACT="ADM")
IF "^43^45^46^"[("^"_$PIECE($GET(VAIP(15,3)),U)_"^")
SET REC=0
+8 ;173
IF TYPE="TRAN"&(EXTRACT="MOV")
Begin DoDot:1
+9 ;173 If there isn't a "next" movement, save it for next month
IF $GET(VAIP(16))=""
SET REC=0
SET ^XTMP("ECXMOV",NEXTMO,MVMT)=""
QUIT
+10 ;173 Don't create a record if it's before the extract start date
IF $PIECE($GET(VAIP(16,1)),U)'>ECSD
SET REC=0
QUIT
+11 ;173 If next movement in timeframe and it's not continuing ASIH or a discharge then create a record
IF $PIECE($GET(VAIP(16,1)),U)'>ECED
IF "^43^45^46^"[("^"_$PIECE($GET(VAIP(16,3)),U)_"^")!(+$GET(VAIP(16,2))'=2)
SET REC=0
QUIT
+12 ;173 If next movement is after extract end date and is in the next month, save it
IF $PIECE($GET(VAIP(16,1)),U)>ECED
SET REC=0
IF $$ECXYM^ECXUTL($PIECE($GET(VAIP(16,1)),U))>$$ECXYM^ECXUTL(ECED)
SET ^XTMP("ECXMOV",NEXTMO,MVMT)=""
End DoDot:1
+13 IF TYPE="DIS"
IF "^43^45^46^"'[("^"_$PIECE($GET(VAIP(15,3)),U)_"^")
SET REC=0
+14 QUIT REC_"^"_$SELECT(REC&(EXTRACT="MOV")&(TYPE="TRAN"):$GET(VAIP(16)),REC:MVMT,1:"")
+15 ;
NEXTMO(DATE) ;173 Given a date, determine the following month and return in year_month format (ex. 201811 for 11/2018)
+1 NEW NEXT,DTSTR
+2 SET NEXT=""
+3 if DATE=""
QUIT NEXT
+4 ;Set DTSTR to first of the month
SET DTSTR=$EXTRACT(DATE,1,5)_"01"
+5 ;Get date 32 days from the 1st of the previous month
SET DTSTR=$$FMADD^XLFDT(DTSTR,32)
+6 ;Subtract number of days into next month to get the last day of the previous month
SET DTSTR=$$FMADD^XLFDT(DTSTR,-($EXTRACT(DTSTR,6,7)))
+7 ;Add one day to get first day of next month
SET DTSTR=$$FMADD^XLFDT(DTSTR,1)
+8 ;Convert FM date to year_month format
SET NEXT=$$ECXYM^ECXUTL(DTSTR)
+9 QUIT NEXT
