- 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 Feb 18, 2025@23:20:51 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