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