Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ECXUTL2

ECXUTL2.m

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