ECXUTL2 ;ALB/JAP - Utilities for DSS Extracts (cont.) ;6/29/18 14:07
;;3.0;DSS EXTRACTS;**8,13,23,24,33,35,39,46,71,84,92,105,112,120,127,144,149,154,166,170,184**;Dec 22, 1997;Build 124
;
; Reference to $$UESTAT^EASUER in ICR #3989
;
ECXDEF(ECXHEAD,ECXPACK,ECXGRP,ECXFILE,ECXRTN,ECXPIECE,ECXVER) ;variables specific to extract from file #727.1
; input
; ECXHEAD = extract header code
; all other formal list parameters passed by reference
; output
; ECXPACK = type field (#7)
; ECXGRP = group field (#9)
; ECXFILE = file number field (#1)
; ECXRTN = routine field (#4)
; ECXPIECE= running piece field (#11)
; ECXVER = dss version
N ECXIEN,ECXARR,DIC,DA,DR,DIQ
S (ECXPACK,ECXGRP,ECXFILE,ECXRTN,ECXPIECE,ECXVER)="",ECXIEN=0
S ECXIEN=+$O(^ECX(727.1,"C",ECXHEAD,ECXIEN))
I ECXIEN=0 D Q
.D MES^XPDUTL(" ")
.D MES^XPDUTL(" It appears that you may have a problem with File #727.1 --")
.D MES^XPDUTL(" ")
.D MES^XPDUTL(" The "_ECHEAD_" Extract is not properly defined.")
.D MES^XPDUTL(" ")
.D MES^XPDUTL(" Contact National VISTA Support for further assistance.")
.D MES^XPDUTL(" ")
.I $E(IOST)="C" D
..S SS=22-$Y F JJ=1:1:SS W !
..S DIR(0)="E" W ! D ^DIR K DIR
.W !!
S DIC="^ECX(727.1,",DA=ECXIEN,DR=".01;1;4;7;9;11;13",DIQ="ECXARR"
D EN^DIQ1
S ECXPACK=ECXARR(727.1,ECXIEN,7)
;if this is an inactive extract type, skip it unless building for audit
I ECXARR(727.1,ECXIEN,13)="YES" I '+$G(ECXAUDIT) D Q ;154, allow extract to run if for audit purposes (ECXAUDIT=1 if coming from audit report)
.D MES^XPDUTL(" ")
.D MES^XPDUTL(" The "_ECHEAD_" Extract is no longer active/valid.")
.D MES^XPDUTL(" ")
.D MES^XPDUTL(" Contact National VISTA Support for further assistance.")
.D MES^XPDUTL(" ")
.I $E(IOST)="C" D
..S SS=22-$Y F JJ=1:1:SS W !
..S DIR(0)="E" W ! D ^DIR K DIR
.W !!
S ECXGRP=ECXARR(727.1,ECXIEN,9)
S ECXFILE=ECXARR(727.1,ECXIEN,1)
S ECXRTN="START^"_ECXARR(727.1,ECXIEN,4)
S ECXPIECE=ECXARR(727.1,ECXIEN,11)
;version of dss/tsi in Austin as specified by btso
S ECXVER=7
Q
PATDEM(DFN,DT1,PAR,FLG) ; determine patient information
; DFN =
; DT =
; PAR =
; FLG =
N DT2,PAT,OK,X
D KPATDEM
S FLG=$G(FLG),PAR=$S($D(PAR):PAR,1:"1;2;3;4;5;"),DT2=$P(DT1,".")
Q:'$$PAT^ECXUTL3(DFN,DT2,PAR,.PAT) 0
S ECXMPI=PAT("MPI")
S ECXSIGI=PAT("SIGI") ;184 Self Identified Gender
I PAR["1" D
.S ECXSSN=PAT("SSN"),ECXPNM=PAT("NAME"),ECXDOB=PAT("DOB")
.S ECXSEX=PAT("SEX"),ECXREL=PAT("RELIGION"),ECXRACE=PAT("RACE")
.S ECXMAR=PAT("MARITAL")
.S ECXETH=PAT("ETHNIC"),ECXRC1=PAT("RACE1")
I PAR["2" D
.S ECXCNTY=PAT("COUNTY"),ECXSTATE=PAT("STATE"),ECXZIP=PAT("ZIP")
.S ECXCNTRY=PAT("COUNTRY")
I PAR["3" D
.S ECXPOS=PAT("POS"),ECSC=PAT("SC STAT"),ECXSVC=PAT("SC%")
.S ECXVET=PAT("VET"),ECXMEAN=PAT("MEANS"),ECXELIG=PAT("ELIG")
.S ECXENRL=PAT("ENROLL LOC")
.S ECXERI=PAT("ERI")
I PAR["4" S ECXEMP=PAT("EMPLOY")
I PAR["5" D
.S ECXVIET=PAT("VIETNAM"),ECXAST=PAT("AO STAT"),ECXRST=PAT("IR STAT")
.S ECXEST=PAT("EC STAT"),ECXPST=PAT("POW STAT"),ECXPLOC=PAT("POW LOC")
.S ECXPHI=PAT("PHI"),ECXMST=PAT("MST STAT"),ECXAOL=PAT("AOL")
.S ECXOEF=PAT("ECXOEF"),ECXOEFDT=PAT("ECXOEFDT")
.S ECXCLST=PAT("CL STAT") ;144 Camp Lejeune Status
.S ECXSVCI=PAT("COMBSVCI") ;149 COMBAT SVC IND
.S ECXSVCL=PAT("COMBSVCL") ;149 COMBAT SVC LOC
I PAR["6" D
.S (ECXPAYOR,ECXSAI)="" D VISN19(DFN,.ECXPAYOR,.ECXSAI)
I FLG'[3 D
.S X=$$PRIMARY(DFN,DT2),ECPTTM=$P(X,U),ECPTPR=$P(X,U,2),ECCLAS=$P(X,U,3)
.S ECPTNPI=$P(X,U,4),ECASPR=$P(X,U,5),ECCLAS2=$P(X,U,6)
.S ECASNPI=$P(X,U,7)
I FLG'[2 D
.S ECXINP=$$INP^ECXUTL2(DFN,DT1),ECXA=$P(ECXINP,U),ECXMN=$P(ECXINP,U,2)
.S ECXTS=$P(ECXINP,U,3),ECXDOM=$P(ECXINP,U,10),ECXADMDT=$P(ECXINP,U,4)
.S WRD=$P(ECXINP,U,5) ;166 tjl - Get WARD (IEN) value
.S ECXDWARD=$P(ECXINP,U,13) ;166 tjl - Get Ward at Discharge IEN
.S ECXASIH=$P(ECXINP,U,14) ;170 Sets ASIH value
I FLG'[1 S X=$$ENROLLM(DFN)
Q 1
;
KPATDEM ;
K ECXADMDT,ECAO,ECASNPI,ECASPR,ECCLAS,ECCLAS2,ECENV,ECPTNPI,ECPTPR,ECPTTM
K ECRE,ECSC,ECXA,ECXAST,ECXCAT,ECXCNTY,ECXEST,ECXENRL,ECXDOB
K ECXDOM,ECXELIG,ECXINP,ECXMPI,ECXMN,ECXNM,ECXPHI,ECXPLOC,ECXMEAN,ECXMST
K ECXPAYOR,ECXPNM,ECXPOS,ECXPRIOR,ECXPST,ECXRACE,ECXREL,ECXRST,ECXSAI
K ECXSEX,ECXSSN,ECXSTAT,ECXSTATE,ECXSVC,ECXTS,ECXVIET,ECXZIP,VA,VAERR
K ECXSBGRP,ECXSVCI,ECXSVCL ;149
Q
ENROLLM(DFN,RNDT) ;determines enrollment status, category, priority
;and user enrollee status
; input
; DFN = IEN from Patient file (Required)
; RNDT = Extract Run Date
; output
; ECXSTAT = Enrollment status
; ECXPRIOR = Enrollment priority
; ECXCAT = Enrollment priority
; ECXSBGRP = Enrollment subgroup
; ECXUESTA = User enrollee
; return value 0 if no data found, 1 if data found
N CAT,PRIOR,STAT,X,X1,X2,X3,ENRIEN,ENR,FL,SBGRP
S (ECXCAT,ECXPRIOR,ECXSTAT,ECXSBGRP,ECXEUSTA)=""
I $G(DFN)="" Q 0
;User enrollee status, if current or future date set to 'U'
;DBIA #3989
S ECXUESTA=$S($$UESTAT^EASUER(DFN):"U",1:"")
;Patient type
S ECXPTYPE=$$TYPE^ECXUTL5(DFN)
;Combat Veteran Status DBIA #4156
S X3=$$CVEDT^ECXUTL5(DFN,$S($G(ECD):ECD,$G(ECXDATE):ECXDATE,1:DT))
;enrollment priority DBIA
S STAT=$$STATUS^DGENA(DFN),PRIOR=$$PRIORITY^DGENA(DFN)
S CAT=$$CATEGORY^DGENA4(DFN,STAT),SBGRP=$$ENRSBGRP^DGENA4(DFN)
;find current enrollment when status=2 or 19
I "^2^19^"[("^"_STAT_"^") S ECXSTAT=STAT,ECXPRIOR=PRIOR,ECXCAT=CAT,ECXSBGRP=$S(SBGRP=1:"a",SBGRP=3:"c",SBGRP=5:"e",SBGRP=7:"g",1:"") Q 1
;find previous enrollment
S ENRIEN=$$FINDCUR^DGENA(DFN) I ENRIEN="" Q 0
I $G(RNDT)="" D NOW^%DTC S RNDT=X
S RNDT=($E(RNDT,1,3)-1)_$E(RNDT,4,7),FL=0
F S ENRIEN=$$FINDPRI^DGENA(ENRIEN) Q:'ENRIEN D Q:FL
. S ENR=$$GET^DGENA(ENRIEN,.ENR)
. I "^2^19^"[("^"_$G(ENR("STATUS"))_"^"),$G(ENR("EFFDATE"))>RNDT D
. . S ECXSTAT=$G(ENR("STATUS")),ECXPRIOR=PRIOR,FL=1
. . S ECXCAT=$$CATEGORY^DGENA4(DFN,ECXSTAT)
. . S ECXSBGRP=$$ENRSBGRP^DGENA4(DFN)
. . S ECXSBGRP=$S(SBGRP=1:"a",SBGRP=3:"c",SBGRP=5:"e",SBGRP=7:"g",1:"")
I FL Q 1
;no enrollment status found =2 or 19
S ECXSTAT=STAT,ECXPRIOR=PRIOR,ECXCAT=CAT,ECXSBGRP=$S(SBGRP=1:"a",SBGRP=3:"c",SBGRP=5:"e",SBGRP=7:"g",1:"")
Q 1
PRIMARY(ECXDFN,ECXDATE,ECXPREFX) ;determine patient's pc team and pc provider
; input
; ECXDFN = file #2 ien (required)
; ECXDATE = date of interest (required)
; ECXPREFX = prefix for provider data (optional)
; defaults to "2" if not specified otherwise
; output
; ECXPRIME = pc team ien^prefix_pc provider ien^pc provider person
;class^pc provider npi^prefix_assoc pc provider ien^assoc pc provider
;person class^assoc pc provider npi
N ECPTTM,ECPTPR,ECCLAS,ECPRIME,ECASPR,ECCLAS2
S:'$D(ECXPREFX) ECXPREFX=2 S:(+ECXPREFX=0) ECXPREFX=2
;get pc team data
S ECPTTM=+$$OUTPTTM^SDUTL3(ECXDFN,ECXDATE) S:ECPTTM=0 ECPTTM=""
;get primary pc provider data
S ECPTPR=+$$OUTPTPR^SDUTL3(ECXDFN,ECXDATE)
S ECCLAS="" I ECPTPR>0 S ECCLAS=$$PRVCLASS^ECXUTL(ECPTPR,ECXDATE)
N ECXUSRTN S ECXUSRTN=$$NPI^XUSNPI("Individual_ID",ECPTPR,ECXDATE)
S:+ECXUSRTN'>0 ECXUSRTN="" S ECPTNPI=$P(ECXUSRTN,U)
S:ECPTPR=0 ECPTPR="" S:ECPTPR]"" ECPTPR=ECXPREFX_ECPTPR
;assoc pc provider call ok if routine scapmca from patch177 is present
S ECASPR=""
S X="SCAPMCA" X ^%ZOSF("TEST") I $T D
.S ECASPR=+$$OUTPTAP^SDUTL3(ECXDFN,ECXDATE)
S ECCLAS2="" I ECASPR>0 S ECCLAS2=$$PRVCLASS^ECXUTL(ECASPR,ECXDATE)
N ECXUSRTN S ECXUSRTN=$$NPI^XUSNPI("Individual_ID",ECASPR,ECXDATE)
S:+ECXUSRTN'>0 ECXUSRTN="" S ECASNPI=$P(ECXUSRTN,U)
S:ECASPR=0 ECASPR="" S:ECASPR]"" ECASPR=ECXPREFX_ECASPR
;assemble
S ECXPRIME=ECPTTM_U_ECPTPR_U_ECCLAS_U_ECPTNPI_U_ECASPR_U_ECCLAS2_U_ECASNPI
Q ECXPRIME
INP(ECXDFN,ECXDATE) ; check for inpatient status
; input
; ECXDFN = file #2 ien (required)
; ECXDATE = date of interest (required)
; output
; ECXINP = patient status^movment # (file #405 ien)
; current treat. spec. (file #42.4 ien)^admission date/time^
; current ward (file #42 ien)^discharge date/time^
; ward provider^attending phys.^ward (file #44 ien);facility
; (file #40.8 ien);dss dept^dom^primary ward phys person class
; ^attending phys person class^ward at discharge^ASIH other facility at date/time?
; ^primary provider taxonomy
; where patient status = I for inpatient
; = O for outpatient
N DFN,DSSDEPT,ECA,ECADM,ECMN,ECTS,ECWARD,ECDC,ECXINP,ECXPRO
N ECXATP,ECXDD,ECXDOM,ECXPROF,ECXPWP,ECXWW,FAC,VAIP,WRD,ECXPWPPC,ECXASIH,ASIHINFO ;170
N ECXATPPC
D FIELD^DID(405,.19,,"SPECIFIER","ECXDD")
S ECXPROF=$E(+$P(ECXDD("SPECIFIER"),"P",2)) K ECXDD
;- Inpat/outpat indicator (ECA) initially set to "O" (outpatient)
S DFN=ECXDFN,ECA="O"
S (DSSDEPT,ECMN,ECTS,ECADM,ECWARD,ECDC,ECXATP,ECXPWP,ECXWW,WRD,FAC,ECXPWPPC,ECXATPPC,ECXDWARD,ECXASIH)="" ;170 Added ECXASIH
S VAIP("D")=ECXDATE D IN5^VADPT
S ECMN=$G(VAIP(1))
I ECMN D
.S ECXASIH=$S("^43^45^46^"[("^"_+VAIP(4)_"^"):1,1:0) ;170 Determine if last movement was a transfer to ASIH other facility
.I ECXASIH S ASIHINFO=$$GETASIH S ECMN=$P($P(ASIHINFO,U),";",2) ;170 If ASIH other facility, set admission movement to ASIH movement
.S ECTS=+$P($G(^DIC(45.7,+VAIP(8),0)),U,2) S:ECTS=0 ECTS=""
.;- Get inpat/outpat indicator
.S ECA=$$INOUTP^ECXUTL4(ECTS)
.S ECADM=$S(ECXASIH:+$P($P(ASIHINFO,U),";"),1:+$G(VAIP(13,1))) S:ECADM=0 ECADM="" ;170 If ASIH movement, admission date/time is ASIH movement date/time
.S ECWARD=+$G(VAIP(5)) S:ECWARD=0 ECWARD=""
.I ECWARD D
..S WRD=+$P($G(^DIC(42,+ECWARD,44)),U)
..S FAC=$P($G(^DIC(42,+ECWARD,0)),U,11)
..S DSSDEPT=$P($G(^ECX(727.4,ECWARD,0)),U,2)
.S ECXWW=WRD_";"_FAC_";"_DSSDEPT,ECDC=$S(ECXASIH:+$P($P(ASIHINFO,U,2),";"),1:+$G(VAIP(17,1))) S:ECDC=0 ECDC="" ;170 If ASIH discharge date/time is return from ASIH other facility else it's discharge date/time
.S ECXPWP=+VAIP(7) S:ECXPWP=0 ECXPWP=""
.S ECXATP=+VAIP(18) S:ECXATP=0 ECXATP=""
.S ECXPWPPC=$$PRVCLASS^ECXUTL(ECXPWP,ECADM)
.S ECXATPPC=$$PRVCLASS^ECXUTL(ECXATP,ECADM)
.;prefix file #200 iens
.S:ECXPWP ECXPWP=ECXPROF_ECXPWP S:ECXATP ECXATP=ECXPROF_ECXATP
S ECXDWARD=+VAIP(17,4) S:ECXDWARD=0 ECXDWARD="" ; 166 tjl - Get Ward at Discharge
S ECXDOM=$P($G(^ECX(727.831,+ECTS,0)),U,2)
S ECXINP=ECA_U_ECMN_U_ECTS_U_ECADM_U_ECWARD_U_ECDC_U_ECXPWP_U_ECXATP_U_ECXWW_U_ECXDOM_U_ECXPWPPC_U_ECXATPPC_U_ECXDWARD_U_ECXASIH ;170 Added ASIH other facility status
Q ECXINP
VISN19(ECXDFN,ECXPAYOR,ECXSAI) ;visn 19 sharing agreement data
; input ECXDFN = patient file ien
; output ECXPAYOR, ECXSAI (passed by reference)
N JJ,ALIAS,INSUR,DIC,DIQ,DA,DR,ECXARY,ECXERR,ECXDA
S (ECXPAYOR,ECXSAI)=""
D GETS^DIQ(2,ECXDFN,"1*,","I","ECXARY","ECXERR")
I $D(ECXERR) Q
S JJ=0 F S JJ=$O(ECXARY(2.01,JJ)) Q:JJ="" D I ECXPAYOR]"" Q
. S ALIAS=$G(ECXARY(2.01,JJ,.01,"I"))
. S ECXPAYOR=$S(ALIAS="SHARING AGREEMENT":"A",ALIAS="TRICARE":"B",ALIAS="CAT C":"C",ALIAS="CATEGORY C":"C",ALIAS="CHAMPVA":"D",ALIAS="CHAMPUS":"E",1:"")
. W !,$G(CNT)+1
. W !,"The value of ECXPAYOR is: ",ECXPAYOR
;K ECXARY,ECXERR
I ECXPAYOR]"" D GETS^DIQ(2,ECXDFN,".3121*,","I","ECXARY","ECXERR") D
. I $D(ECXERR) Q
. S JJ=0,ECXDA=$O(ECXARY(2.312,JJ)) I ECXDA="" Q
. S DA=$G(ECXARY(2.312,ECXDA,.01,"I")) I DA="" Q
. S INSUR=$$GET1^DIQ(36,DA,".01","I","","ECXERR")
. I '$D(ECXERR) S ECXSAI=$E(ECXARY(2.312,ECXDA,.01,"I"),1,11)
Q
;
GETASIH() ;170 Section added to determine start and end of ASIH other facility movement
N MVMTDT,CLCADM,DATE,REC,DONE,ASIHSD,ASIHED
S MVMTDT=+VAIP(3) ;ASIH movement date/time
S CLCADM=VAIP(13) ;CLC admit date/time (NHUC, DOM, etc.)
;Get ASIH start date/time
S ASIHSD=MVMTDT_";"_$G(ECMN),DATE=MVMTDT
S DONE=0 F S DATE=$O(^DGPM("APCA",DFN,CLCADM,DATE),-1) Q:DATE=""!(DONE) D
.S DA=$O(^DGPM("APCA",DFN,CLCADM,DATE,0))
.S REC=$G(^DGPM(DA,0))
.I "^43^45^46^"'[("^"_$P(REC,U,18)_"^") S DONE=1 Q ;If previous movement isn't an ASIH other facility type movement, stop
.S ASIHSD=$P(REC,U)_";"_DA
;Now get ending time if available
S DATE=MVMTDT
S ASIHED=""
S DONE=0 F S DATE=$O(^DGPM("APCA",DFN,CLCADM,DATE)) Q:DATE=""!(DONE) D
.S DA=$O(^DGPM("APCA",DFN,CLCADM,DATE,0))
.S REC=$G(^DGPM(DA,0))
.I "^43^45^46^"'[("^"_$P(REC,U,18)_"^") D
..I $P(REC,U,2)'=3 S ASIHED=$P(REC,U)_";"_DA S DONE=1 Q ;If non-ASIH movement then end date/time is movement date/time
..I $P(REC,U,2)=3&($P(REC,U)<+$G(ECED)) S ASIHED=$P(REC,U)_";"_DA,DONE=1 Q ;If next movement is discharge, and the discharge has happened then end date/time is discharge date/time
Q ASIHSD_"^"_ASIHED
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECXUTL2 12740 printed Oct 16, 2024@17:55:08 Page 2
ECXUTL2 ;ALB/JAP - Utilities for DSS Extracts (cont.) ;6/29/18 14:07
+1 ;;3.0;DSS EXTRACTS;**8,13,23,24,33,35,39,46,71,84,92,105,112,120,127,144,149,154,166,170,184**;Dec 22, 1997;Build 124
+2 ;
+3 ; Reference to $$UESTAT^EASUER in ICR #3989
+4 ;
ECXDEF(ECXHEAD,ECXPACK,ECXGRP,ECXFILE,ECXRTN,ECXPIECE,ECXVER) ;variables specific to extract from file #727.1
+1 ; input
+2 ; ECXHEAD = extract header code
+3 ; all other formal list parameters passed by reference
+4 ; output
+5 ; ECXPACK = type field (#7)
+6 ; ECXGRP = group field (#9)
+7 ; ECXFILE = file number field (#1)
+8 ; ECXRTN = routine field (#4)
+9 ; ECXPIECE= running piece field (#11)
+10 ; ECXVER = dss version
+11 NEW ECXIEN,ECXARR,DIC,DA,DR,DIQ
+12 SET (ECXPACK,ECXGRP,ECXFILE,ECXRTN,ECXPIECE,ECXVER)=""
SET ECXIEN=0
+13 SET ECXIEN=+$ORDER(^ECX(727.1,"C",ECXHEAD,ECXIEN))
+14 IF ECXIEN=0
Begin DoDot:1
+15 DO MES^XPDUTL(" ")
+16 DO MES^XPDUTL(" It appears that you may have a problem with File #727.1 --")
+17 DO MES^XPDUTL(" ")
+18 DO MES^XPDUTL(" The "_ECHEAD_" Extract is not properly defined.")
+19 DO MES^XPDUTL(" ")
+20 DO MES^XPDUTL(" Contact National VISTA Support for further assistance.")
+21 DO MES^XPDUTL(" ")
+22 IF $EXTRACT(IOST)="C"
Begin DoDot:2
+23 SET SS=22-$Y
FOR JJ=1:1:SS
WRITE !
+24 SET DIR(0)="E"
WRITE !
DO ^DIR
KILL DIR
End DoDot:2
+25 WRITE !!
End DoDot:1
QUIT
+26 SET DIC="^ECX(727.1,"
SET DA=ECXIEN
SET DR=".01;1;4;7;9;11;13"
SET DIQ="ECXARR"
+27 DO EN^DIQ1
+28 SET ECXPACK=ECXARR(727.1,ECXIEN,7)
+29 ;if this is an inactive extract type, skip it unless building for audit
+30 ;154, allow extract to run if for audit purposes (ECXAUDIT=1 if coming from audit report)
IF ECXARR(727.1,ECXIEN,13)="YES"
IF '+$GET(ECXAUDIT)
Begin DoDot:1
+31 DO MES^XPDUTL(" ")
+32 DO MES^XPDUTL(" The "_ECHEAD_" Extract is no longer active/valid.")
+33 DO MES^XPDUTL(" ")
+34 DO MES^XPDUTL(" Contact National VISTA Support for further assistance.")
+35 DO MES^XPDUTL(" ")
+36 IF $EXTRACT(IOST)="C"
Begin DoDot:2
+37 SET SS=22-$Y
FOR JJ=1:1:SS
WRITE !
+38 SET DIR(0)="E"
WRITE !
DO ^DIR
KILL DIR
End DoDot:2
+39 WRITE !!
End DoDot:1
QUIT
+40 SET ECXGRP=ECXARR(727.1,ECXIEN,9)
+41 SET ECXFILE=ECXARR(727.1,ECXIEN,1)
+42 SET ECXRTN="START^"_ECXARR(727.1,ECXIEN,4)
+43 SET ECXPIECE=ECXARR(727.1,ECXIEN,11)
+44 ;version of dss/tsi in Austin as specified by btso
+45 SET ECXVER=7
+46 QUIT
PATDEM(DFN,DT1,PAR,FLG) ; determine patient information
+1 ; DFN =
+2 ; DT =
+3 ; PAR =
+4 ; FLG =
+5 NEW DT2,PAT,OK,X
+6 DO KPATDEM
+7 SET FLG=$GET(FLG)
SET PAR=$SELECT($DATA(PAR):PAR,1:"1;2;3;4;5;")
SET DT2=$PIECE(DT1,".")
+8 if '$$PAT^ECXUTL3(DFN,DT2,PAR,.PAT)
QUIT 0
+9 SET ECXMPI=PAT("MPI")
+10 ;184 Self Identified Gender
SET ECXSIGI=PAT("SIGI")
+11 IF PAR["1"
Begin DoDot:1
+12 SET ECXSSN=PAT("SSN")
SET ECXPNM=PAT("NAME")
SET ECXDOB=PAT("DOB")
+13 SET ECXSEX=PAT("SEX")
SET ECXREL=PAT("RELIGION")
SET ECXRACE=PAT("RACE")
+14 SET ECXMAR=PAT("MARITAL")
+15 SET ECXETH=PAT("ETHNIC")
SET ECXRC1=PAT("RACE1")
End DoDot:1
+16 IF PAR["2"
Begin DoDot:1
+17 SET ECXCNTY=PAT("COUNTY")
SET ECXSTATE=PAT("STATE")
SET ECXZIP=PAT("ZIP")
+18 SET ECXCNTRY=PAT("COUNTRY")
End DoDot:1
+19 IF PAR["3"
Begin DoDot:1
+20 SET ECXPOS=PAT("POS")
SET ECSC=PAT("SC STAT")
SET ECXSVC=PAT("SC%")
+21 SET ECXVET=PAT("VET")
SET ECXMEAN=PAT("MEANS")
SET ECXELIG=PAT("ELIG")
+22 SET ECXENRL=PAT("ENROLL LOC")
+23 SET ECXERI=PAT("ERI")
End DoDot:1
+24 IF PAR["4"
SET ECXEMP=PAT("EMPLOY")
+25 IF PAR["5"
Begin DoDot:1
+26 SET ECXVIET=PAT("VIETNAM")
SET ECXAST=PAT("AO STAT")
SET ECXRST=PAT("IR STAT")
+27 SET ECXEST=PAT("EC STAT")
SET ECXPST=PAT("POW STAT")
SET ECXPLOC=PAT("POW LOC")
+28 SET ECXPHI=PAT("PHI")
SET ECXMST=PAT("MST STAT")
SET ECXAOL=PAT("AOL")
+29 SET ECXOEF=PAT("ECXOEF")
SET ECXOEFDT=PAT("ECXOEFDT")
+30 ;144 Camp Lejeune Status
SET ECXCLST=PAT("CL STAT")
+31 ;149 COMBAT SVC IND
SET ECXSVCI=PAT("COMBSVCI")
+32 ;149 COMBAT SVC LOC
SET ECXSVCL=PAT("COMBSVCL")
End DoDot:1
+33 IF PAR["6"
Begin DoDot:1
+34 SET (ECXPAYOR,ECXSAI)=""
DO VISN19(DFN,.ECXPAYOR,.ECXSAI)
End DoDot:1
+35 IF FLG'[3
Begin DoDot:1
+36 SET X=$$PRIMARY(DFN,DT2)
SET ECPTTM=$PIECE(X,U)
SET ECPTPR=$PIECE(X,U,2)
SET ECCLAS=$PIECE(X,U,3)
+37 SET ECPTNPI=$PIECE(X,U,4)
SET ECASPR=$PIECE(X,U,5)
SET ECCLAS2=$PIECE(X,U,6)
+38 SET ECASNPI=$PIECE(X,U,7)
End DoDot:1
+39 IF FLG'[2
Begin DoDot:1
+40 SET ECXINP=$$INP^ECXUTL2(DFN,DT1)
SET ECXA=$PIECE(ECXINP,U)
SET ECXMN=$PIECE(ECXINP,U,2)
+41 SET ECXTS=$PIECE(ECXINP,U,3)
SET ECXDOM=$PIECE(ECXINP,U,10)
SET ECXADMDT=$PIECE(ECXINP,U,4)
+42 ;166 tjl - Get WARD (IEN) value
SET WRD=$PIECE(ECXINP,U,5)
+43 ;166 tjl - Get Ward at Discharge IEN
SET ECXDWARD=$PIECE(ECXINP,U,13)
+44 ;170 Sets ASIH value
SET ECXASIH=$PIECE(ECXINP,U,14)
End DoDot:1
+45 IF FLG'[1
SET X=$$ENROLLM(DFN)
+46 QUIT 1
+47 ;
KPATDEM ;
+1 KILL ECXADMDT,ECAO,ECASNPI,ECASPR,ECCLAS,ECCLAS2,ECENV,ECPTNPI,ECPTPR,ECPTTM
+2 KILL ECRE,ECSC,ECXA,ECXAST,ECXCAT,ECXCNTY,ECXEST,ECXENRL,ECXDOB
+3 KILL ECXDOM,ECXELIG,ECXINP,ECXMPI,ECXMN,ECXNM,ECXPHI,ECXPLOC,ECXMEAN,ECXMST
+4 KILL ECXPAYOR,ECXPNM,ECXPOS,ECXPRIOR,ECXPST,ECXRACE,ECXREL,ECXRST,ECXSAI
+5 KILL ECXSEX,ECXSSN,ECXSTAT,ECXSTATE,ECXSVC,ECXTS,ECXVIET,ECXZIP,VA,VAERR
+6 ;149
KILL ECXSBGRP,ECXSVCI,ECXSVCL
+7 QUIT
ENROLLM(DFN,RNDT) ;determines enrollment status, category, priority
+1 ;and user enrollee status
+2 ; input
+3 ; DFN = IEN from Patient file (Required)
+4 ; RNDT = Extract Run Date
+5 ; output
+6 ; ECXSTAT = Enrollment status
+7 ; ECXPRIOR = Enrollment priority
+8 ; ECXCAT = Enrollment priority
+9 ; ECXSBGRP = Enrollment subgroup
+10 ; ECXUESTA = User enrollee
+11 ; return value 0 if no data found, 1 if data found
+12 NEW CAT,PRIOR,STAT,X,X1,X2,X3,ENRIEN,ENR,FL,SBGRP
+13 SET (ECXCAT,ECXPRIOR,ECXSTAT,ECXSBGRP,ECXEUSTA)=""
+14 IF $GET(DFN)=""
QUIT 0
+15 ;User enrollee status, if current or future date set to 'U'
+16 ;DBIA #3989
+17 SET ECXUESTA=$SELECT($$UESTAT^EASUER(DFN):"U",1:"")
+18 ;Patient type
+19 SET ECXPTYPE=$$TYPE^ECXUTL5(DFN)
+20 ;Combat Veteran Status DBIA #4156
+21 SET X3=$$CVEDT^ECXUTL5(DFN,$SELECT($GET(ECD):ECD,$GET(ECXDATE):ECXDATE,1:DT))
+22 ;enrollment priority DBIA
+23 SET STAT=$$STATUS^DGENA(DFN)
SET PRIOR=$$PRIORITY^DGENA(DFN)
+24 SET CAT=$$CATEGORY^DGENA4(DFN,STAT)
SET SBGRP=$$ENRSBGRP^DGENA4(DFN)
+25 ;find current enrollment when status=2 or 19
+26 IF "^2^19^"[("^"_STAT_"^")
SET ECXSTAT=STAT
SET ECXPRIOR=PRIOR
SET ECXCAT=CAT
SET ECXSBGRP=$SELECT(SBGRP=1:"a",SBGRP=3:"c",SBGRP=5:"e",SBGRP=7:"g",1:"")
QUIT 1
+27 ;find previous enrollment
+28 SET ENRIEN=$$FINDCUR^DGENA(DFN)
IF ENRIEN=""
QUIT 0
+29 IF $GET(RNDT)=""
DO NOW^%DTC
SET RNDT=X
+30 SET RNDT=($EXTRACT(RNDT,1,3)-1)_$EXTRACT(RNDT,4,7)
SET FL=0
+31 FOR
SET ENRIEN=$$FINDPRI^DGENA(ENRIEN)
if 'ENRIEN
QUIT
Begin DoDot:1
+32 SET ENR=$$GET^DGENA(ENRIEN,.ENR)
+33 IF "^2^19^"[("^"_$GET(ENR("STATUS"))_"^")
IF $GET(ENR("EFFDATE"))>RNDT
Begin DoDot:2
+34 SET ECXSTAT=$GET(ENR("STATUS"))
SET ECXPRIOR=PRIOR
SET FL=1
+35 SET ECXCAT=$$CATEGORY^DGENA4(DFN,ECXSTAT)
+36 SET ECXSBGRP=$$ENRSBGRP^DGENA4(DFN)
+37 SET ECXSBGRP=$SELECT(SBGRP=1:"a",SBGRP=3:"c",SBGRP=5:"e",SBGRP=7:"g",1:"")
End DoDot:2
End DoDot:1
if FL
QUIT
+38 IF FL
QUIT 1
+39 ;no enrollment status found =2 or 19
+40 SET ECXSTAT=STAT
SET ECXPRIOR=PRIOR
SET ECXCAT=CAT
SET ECXSBGRP=$SELECT(SBGRP=1:"a",SBGRP=3:"c",SBGRP=5:"e",SBGRP=7:"g",1:"")
+41 QUIT 1
PRIMARY(ECXDFN,ECXDATE,ECXPREFX) ;determine patient's pc team and pc provider
+1 ; input
+2 ; ECXDFN = file #2 ien (required)
+3 ; ECXDATE = date of interest (required)
+4 ; ECXPREFX = prefix for provider data (optional)
+5 ; defaults to "2" if not specified otherwise
+6 ; output
+7 ; ECXPRIME = pc team ien^prefix_pc provider ien^pc provider person
+8 ;class^pc provider npi^prefix_assoc pc provider ien^assoc pc provider
+9 ;person class^assoc pc provider npi
+10 NEW ECPTTM,ECPTPR,ECCLAS,ECPRIME,ECASPR,ECCLAS2
+11 if '$DATA(ECXPREFX)
SET ECXPREFX=2
if (+ECXPREFX=0)
SET ECXPREFX=2
+12 ;get pc team data
+13 SET ECPTTM=+$$OUTPTTM^SDUTL3(ECXDFN,ECXDATE)
if ECPTTM=0
SET ECPTTM=""
+14 ;get primary pc provider data
+15 SET ECPTPR=+$$OUTPTPR^SDUTL3(ECXDFN,ECXDATE)
+16 SET ECCLAS=""
IF ECPTPR>0
SET ECCLAS=$$PRVCLASS^ECXUTL(ECPTPR,ECXDATE)
+17 NEW ECXUSRTN
SET ECXUSRTN=$$NPI^XUSNPI("Individual_ID",ECPTPR,ECXDATE)
+18 if +ECXUSRTN'>0
SET ECXUSRTN=""
SET ECPTNPI=$PIECE(ECXUSRTN,U)
+19 if ECPTPR=0
SET ECPTPR=""
if ECPTPR]""
SET ECPTPR=ECXPREFX_ECPTPR
+20 ;assoc pc provider call ok if routine scapmca from patch177 is present
+21 SET ECASPR=""
+22 SET X="SCAPMCA"
XECUTE ^%ZOSF("TEST")
IF $TEST
Begin DoDot:1
+23 SET ECASPR=+$$OUTPTAP^SDUTL3(ECXDFN,ECXDATE)
End DoDot:1
+24 SET ECCLAS2=""
IF ECASPR>0
SET ECCLAS2=$$PRVCLASS^ECXUTL(ECASPR,ECXDATE)
+25 NEW ECXUSRTN
SET ECXUSRTN=$$NPI^XUSNPI("Individual_ID",ECASPR,ECXDATE)
+26 if +ECXUSRTN'>0
SET ECXUSRTN=""
SET ECASNPI=$PIECE(ECXUSRTN,U)
+27 if ECASPR=0
SET ECASPR=""
if ECASPR]""
SET ECASPR=ECXPREFX_ECASPR
+28 ;assemble
+29 SET ECXPRIME=ECPTTM_U_ECPTPR_U_ECCLAS_U_ECPTNPI_U_ECASPR_U_ECCLAS2_U_ECASNPI
+30 QUIT ECXPRIME
INP(ECXDFN,ECXDATE) ; check for inpatient status
+1 ; input
+2 ; ECXDFN = file #2 ien (required)
+3 ; ECXDATE = date of interest (required)
+4 ; output
+5 ; ECXINP = patient status^movment # (file #405 ien)
+6 ; current treat. spec. (file #42.4 ien)^admission date/time^
+7 ; current ward (file #42 ien)^discharge date/time^
+8 ; ward provider^attending phys.^ward (file #44 ien);facility
+9 ; (file #40.8 ien);dss dept^dom^primary ward phys person class
+10 ; ^attending phys person class^ward at discharge^ASIH other facility at date/time?
+11 ; ^primary provider taxonomy
+12 ; where patient status = I for inpatient
+13 ; = O for outpatient
+14 NEW DFN,DSSDEPT,ECA,ECADM,ECMN,ECTS,ECWARD,ECDC,ECXINP,ECXPRO
+15 ;170
NEW ECXATP,ECXDD,ECXDOM,ECXPROF,ECXPWP,ECXWW,FAC,VAIP,WRD,ECXPWPPC,ECXASIH,ASIHINFO
+16 NEW ECXATPPC
+17 DO FIELD^DID(405,.19,,"SPECIFIER","ECXDD")
+18 SET ECXPROF=$EXTRACT(+$PIECE(ECXDD("SPECIFIER"),"P",2))
KILL ECXDD
+19 ;- Inpat/outpat indicator (ECA) initially set to "O" (outpatient)
+20 SET DFN=ECXDFN
SET ECA="O"
+21 ;170 Added ECXASIH
SET (DSSDEPT,ECMN,ECTS,ECADM,ECWARD,ECDC,ECXATP,ECXPWP,ECXWW,WRD,FAC,ECXPWPPC,ECXATPPC,ECXDWARD,ECXASIH)=""
+22 SET VAIP("D")=ECXDATE
DO IN5^VADPT
+23 SET ECMN=$GET(VAIP(1))
+24 IF ECMN
Begin DoDot:1
+25 ;170 Determine if last movement was a transfer to ASIH other facility
SET ECXASIH=$SELECT("^43^45^46^"[("^"_+VAIP(4)_"^"):1,1:0)
+26 ;170 If ASIH other facility, set admission movement to ASIH movement
IF ECXASIH
SET ASIHINFO=$$GETASIH
SET ECMN=$PIECE($PIECE(ASIHINFO,U),";",2)
+27 SET ECTS=+$PIECE($GET(^DIC(45.7,+VAIP(8),0)),U,2)
if ECTS=0
SET ECTS=""
+28 ;- Get inpat/outpat indicator
+29 SET ECA=$$INOUTP^ECXUTL4(ECTS)
+30 ;170 If ASIH movement, admission date/time is ASIH movement date/time
SET ECADM=$SELECT(ECXASIH:+$PIECE($PIECE(ASIHINFO,U),";"),1:+$GET(VAIP(13,1)))
if ECADM=0
SET ECADM=""
+31 SET ECWARD=+$GET(VAIP(5))
if ECWARD=0
SET ECWARD=""
+32 IF ECWARD
Begin DoDot:2
+33 SET WRD=+$PIECE($GET(^DIC(42,+ECWARD,44)),U)
+34 SET FAC=$PIECE($GET(^DIC(42,+ECWARD,0)),U,11)
+35 SET DSSDEPT=$PIECE($GET(^ECX(727.4,ECWARD,0)),U,2)
End DoDot:2
+36 ;170 If ASIH discharge date/time is return from ASIH other facility else it's discharge date/time
SET ECXWW=WRD_";"_FAC_";"_DSSDEPT
SET ECDC=$SELECT(ECXASIH:+$PIECE($PIECE(ASIHINFO,U,2),";"),1:+$GET(VAIP(17,1)))
if ECDC=0
SET ECDC=""
+37 SET ECXPWP=+VAIP(7)
if ECXPWP=0
SET ECXPWP=""
+38 SET ECXATP=+VAIP(18)
if ECXATP=0
SET ECXATP=""
+39 SET ECXPWPPC=$$PRVCLASS^ECXUTL(ECXPWP,ECADM)
+40 SET ECXATPPC=$$PRVCLASS^ECXUTL(ECXATP,ECADM)
+41 ;prefix file #200 iens
+42 if ECXPWP
SET ECXPWP=ECXPROF_ECXPWP
if ECXATP
SET ECXATP=ECXPROF_ECXATP
End DoDot:1
+43 ; 166 tjl - Get Ward at Discharge
SET ECXDWARD=+VAIP(17,4)
if ECXDWARD=0
SET ECXDWARD=""
+44 SET ECXDOM=$PIECE($GET(^ECX(727.831,+ECTS,0)),U,2)
+45 ;170 Added ASIH other facility status
SET ECXINP=ECA_U_ECMN_U_ECTS_U_ECADM_U_ECWARD_U_ECDC_U_ECXPWP_U_ECXATP_U_ECXWW_U_ECXDOM_U_ECXPWPPC_U_ECXATPPC_U_ECXDWARD_U_ECXASIH
+46 QUIT ECXINP
VISN19(ECXDFN,ECXPAYOR,ECXSAI) ;visn 19 sharing agreement data
+1 ; input ECXDFN = patient file ien
+2 ; output ECXPAYOR, ECXSAI (passed by reference)
+3 NEW JJ,ALIAS,INSUR,DIC,DIQ,DA,DR,ECXARY,ECXERR,ECXDA
+4 SET (ECXPAYOR,ECXSAI)=""
+5 DO GETS^DIQ(2,ECXDFN,"1*,","I","ECXARY","ECXERR")
+6 IF $DATA(ECXERR)
QUIT
+7 SET JJ=0
FOR
SET JJ=$ORDER(ECXARY(2.01,JJ))
if JJ=""
QUIT
Begin DoDot:1
+8 SET ALIAS=$GET(ECXARY(2.01,JJ,.01,"I"))
+9 SET ECXPAYOR=$SELECT(ALIAS="SHARING AGREEMENT":"A",ALIAS="TRICARE":"B",ALIAS="CAT C":"C",ALIAS="CATEGORY C":"C",ALIAS="CHAMPVA":"D",ALIAS="CHAMPUS":"E",1:"")
+10 WRITE !,$GET(CNT)+1
+11 WRITE !,"The value of ECXPAYOR is: ",ECXPAYOR
End DoDot:1
IF ECXPAYOR]""
QUIT
+12 ;K ECXARY,ECXERR
+13 IF ECXPAYOR]""
DO GETS^DIQ(2,ECXDFN,".3121*,","I","ECXARY","ECXERR")
Begin DoDot:1
+14 IF $DATA(ECXERR)
QUIT
+15 SET JJ=0
SET ECXDA=$ORDER(ECXARY(2.312,JJ))
IF ECXDA=""
QUIT
+16 SET DA=$GET(ECXARY(2.312,ECXDA,.01,"I"))
IF DA=""
QUIT
+17 SET INSUR=$$GET1^DIQ(36,DA,".01","I","","ECXERR")
+18 IF '$DATA(ECXERR)
SET ECXSAI=$EXTRACT(ECXARY(2.312,ECXDA,.01,"I"),1,11)
End DoDot:1
+19 QUIT
+20 ;
GETASIH() ;170 Section added to determine start and end of ASIH other facility movement
+1 NEW MVMTDT,CLCADM,DATE,REC,DONE,ASIHSD,ASIHED
+2 ;ASIH movement date/time
SET MVMTDT=+VAIP(3)
+3 ;CLC admit date/time (NHUC, DOM, etc.)
SET CLCADM=VAIP(13)
+4 ;Get ASIH start date/time
+5 SET ASIHSD=MVMTDT_";"_$GET(ECMN)
SET DATE=MVMTDT
+6 SET DONE=0
FOR
SET DATE=$ORDER(^DGPM("APCA",DFN,CLCADM,DATE),-1)
if DATE=""!(DONE)
QUIT
Begin DoDot:1
+7 SET DA=$ORDER(^DGPM("APCA",DFN,CLCADM,DATE,0))
+8 SET REC=$GET(^DGPM(DA,0))
+9 ;If previous movement isn't an ASIH other facility type movement, stop
IF "^43^45^46^"'[("^"_$PIECE(REC,U,18)_"^")
SET DONE=1
QUIT
+10 SET ASIHSD=$PIECE(REC,U)_";"_DA
End DoDot:1
+11 ;Now get ending time if available
+12 SET DATE=MVMTDT
+13 SET ASIHED=""
+14 SET DONE=0
FOR
SET DATE=$ORDER(^DGPM("APCA",DFN,CLCADM,DATE))
if DATE=""!(DONE)
QUIT
Begin DoDot:1
+15 SET DA=$ORDER(^DGPM("APCA",DFN,CLCADM,DATE,0))
+16 SET REC=$GET(^DGPM(DA,0))
+17 IF "^43^45^46^"'[("^"_$PIECE(REC,U,18)_"^")
Begin DoDot:2
+18 ;If non-ASIH movement then end date/time is movement date/time
IF $PIECE(REC,U,2)'=3
SET ASIHED=$PIECE(REC,U)_";"_DA
SET DONE=1
QUIT
+19 ;If next movement is discharge, and the discharge has happened then end date/time is discharge date/time
IF $PIECE(REC,U,2)=3&($PIECE(REC,U)<+$GET(ECED))
SET ASIHED=$PIECE(REC,U)_";"_DA
SET DONE=1
QUIT
End DoDot:2
End DoDot:1
+20 QUIT ASIHSD_"^"_ASIHED
