ECXUTL3 ;ALB/GTS - Utilities for DSS Extracts ;9/4/18 13:18
;;3.0;DSS EXTRACTS;**11,24,32,33,35,37,39,42,46,92,105,120,144,149,154,166,170,184,187**;Dec 22,1997;Build 163
;
; Reference to ^DPT( in ICR #1850
; Reference to $$GETSTAT^DGMSTAPI in ICR #2716
; Reference to $$PTR2CODE^DGUTL4,$$PTR2TEXT^DGUTL4 in ICR #3799
;
OUTPTTM(ECXDFN,ECXDT) ;* Return PC Team from PCMM files or DPT
; Variables -
; ECXDFN - IEN from Patient file (Required)
; ECXDT - Relevant Date for Primary Care Team
; (Defaults to DT)
;
; Returned: ECXTM -
; Pointer to team file (#404.51)
; or, if error or none defined, returns 0
;
Q:'$G(ECXDFN) 0 ;** Quit if ECXDFN not defined
N ECXTM
S:'$D(ECXDT) ECXDT=DT
I $T(OUTPTTM^SDUTL3)[",SCDATE" D
.S ECXTM=+$$OUTPTTM^SDUTL3(ECXDFN,ECXDT)
I $T(OUTPTTM^SDUTL3)'[",SCDATE" D
.S ECXTM=+$$OUTPTTM^SDUTL3(ECXDFN)
I ECXTM=0 D
.S ECXTM=+$P($G(^DPT(+ECXDFN,"PC")),U,2)
Q ECXTM
;
OUTPTPR(ECXDFN,ECXDT) ;* Return PC Provider from PCMM files or DPT
; Variables -
; ECXDFN - IEN from Patient file (Required)
; ECXDT - Relevant Date for Primary Care Provider
; (Defaults to DT)
;
; Returned: ECXPR -
; Pointer to file #200
; or, if error or none defined, returns a 0
;
Q:'$G(ECXDFN) 0 ;** Quit if ECXDFN not defined
N ECXPR
S:'$D(ECXDT) ECXDT=DT
I $T(OUTPTPR^SDUTL3)[",SCDATE" D
.S ECXPR=+$$OUTPTPR^SDUTL3(ECXDFN,ECXDT)
I $T(OUTPTPR^SDUTL3)'[",SCDATE" D
.S ECXPR=+$$OUTPTPR^SDUTL3(ECXDFN)
I ECXPR=0 D
.S ECXPR=+$G(^DPT(+ECXDFN,"PC"))
Q ECXPR
;
PAT(ECXDFN,ECXDATE,ECXDATA,ECXPAT) ;Return basic patient data for extract
; Will not return data associated with test patients (SSN begin w 00000)
; Variables -
; Input ECXDFN - Patient internal entry number, DFN file#2; required
; ECXDATE- Date used to get specific data from GETSTAT^DGMSTAPI
; for MST. If no date, defaults to today's date,
; standard FM format, optional
; ECXDATA- Code indicating which data to return, optional.
; If code not specified then returns all. Codes are:
; 1 - DEM^VADPT (demographic data)
; 2 - ADD^VADPT (current address)
; 3 - ELIG^VADPT (eligibility & enrollment location)
; 4 - OPD^VADPT (other patient data)
; 5 - SVC^VADPT & GETSTAT^DGMSTAPI (service & MST inf)
; ECXPAT(- Passed by reference; required
;
; Output:
; ECXPAT 0 error or test patient no data in ECXPAT array
; 1 data returned in ECXPAT array
; ECXPAT( Local array with patient data.
;
N SSN,I,ECXCOD,ECXDAT,DFN,VAPA,VADM,VAEL,VAPD,VASV,STR,ECXAR,DIC,DIQ,RCNUM,RCVAL,COLMETH
N DA,DR,PELG,MELIG,ZIP,MPI,PTNAME ;187 Added PTNAME
I ECXDFN="" Q 0
S PTNAME=$$GET1^DIQ(2,ECXDFN,.01,"I") ;187
I $E(PTNAME,1,2)="ZZ" Q 0 ;187 - exclude patient whose name started with "ZZ"
S SSN=$$GET1^DIQ(2,ECXDFN,.09,"I"),DFN=ECXDFN,ECXPAT=0
;I $E(SSN,1,3)="000"!(SSN="") K ECXPAT Q 0 ;154 removed as these checks are done in ECXUTL5 ;test patient
;test patient extended checks; mtl extract excluded
I $G(ECHEAD)'="MTL" D I $G(ECXPAT)="" Q 0 ;154 modified section for SSN testing
.I $G(ECHEAD)="ECS" I $E(SSN,1,5)="00000" I "^CH103^CH104^CH105^CH106^CH107^CH108^CH109^"[("^"_$G(ECPNM)_"^") Q ;154 If event capture extract and 5 leading zeroes test patient and workload is CH103 to CH109 then allow test SSN
.I '$$SSN^ECXUTL5(SSN) K ECXPAT
S STR="NAME;SSN;DOB;SEX;RACE;RELIGION;STATE;COUNTY;ZIP;SC%;MEANS;ELIG;"
S STR=STR_"EMPLOY;AO STAT;IR STAT;EC STAT;POW STAT;POW LOC;MST STAT;"
S STR=STR_"ENROLL LOC;MPI;VIETNAM;POS;MARITAL;CL STAT;COMBSVCI;COMBSVCL" ;149 COMB SVS IND,LOC
;initialize return array values
F I=1:1 S ECXDAT=$P(STR,";",I) Q:ECXDAT="" S ECXPAT(ECXDAT)=""
F I=1:1:$L(ECXDATA,";") S ECXDAT=$P(ECXDATA,";",I) I ECXDAT'="" D
. S ECXCOD(ECXDAT)=""
;
;- Get ICN if MPI installed
S X="MPIF001" X ^%ZOSF("TEST") I $T D
.;
.;- Get 1st piece (either ICN # or -1 if error)
. S MPI=$$GETICN^MPIF001(DFN) ;184 - Removed "+" to include the check sum
.;
.;- If error, set to null
. S ECXPAT("MPI")=$S(MPI>0:MPI,1:"")
D ;get demographic data
. I ECXDATA'="",'$D(ECXCOD(1)) Q
. D DEM^VADPT
. S ECXPAT("NAME")=$E($P(VADM(1),",")_" ",1,4)
. S ECXPAT("SSN")=$P(VADM(2),U),ECXPAT("MARITAL")=$P(VADM(10),U)
. S ECXPAT("DOB")=$$ECXDOB^ECXUTL($P(VADM(3),U))
. S ECXPAT("SEX")=$P(VADM(5),U),ECXPAT("RELIGION")=$P(VADM(9),U)
. S ECXPAT("SIGI")=$P(VADM(14,5),U,2) ;184 - Add SIGI Code
. S DIC=10,DR=2,DA=+VADM(8),DIQ="ECXAR",DIQ(0)="I" D EN^DIQ1
. S ECXPAT("RACE")=$G(ECXAR(10,DA,DR,"I")),ECXPAT=1
. ;add new race and ethnicity fields for FY2003
. S (ECXPAT("ETHNIC"),ECXPAT("RACE1"))=""
. S X="DGUTL4" X ^%ZOSF("TEST") I $T D
.. S COLMETH=$$PTR2CODE^DGUTL4($G(VADM(11,1,1)),3,4) I COLMETH="S" D
... S ECXPAT("ETHNIC")=$$PTR2CODE^DGUTL4(+$G(VADM(11,1)),2,4)
.. S (RCVAL,RCNUM)=""
.. F S RCNUM=$O(VADM(12,RCNUM)) Q:RCNUM="" Q:RCVAL="C" S COLMETH=$$PTR2CODE^DGUTL4(+$G(VADM(12,RCNUM,1)),3,4) I COLMETH="S" D
... S RCVAL=$$PTR2CODE^DGUTL4(+$G(VADM(12,RCNUM)),1,4)
... I RCVAL="C" S ECXPAT("RACE1")=RCVAL Q
... S ECXPAT("RACE1")=ECXPAT("RACE1")_RCVAL
.I ECXPAT("RACE1")="" S ECXPAT("RACE1")=$$CHECKRC(+VADM(8)) ;144 If RACE1 is null, check value in RACE field
D ;get address information
. I ECXDATA'="",'$D(ECXCOD(2)) Q
. D ADD^VADPT
. S DIC=5,DR=2,DA=+VAPA(5),DIQ="ECXAR",DIQ(0)="I" D EN^DIQ1
. S ECXPAT("STATE")=$G(ECXAR(5,DA,DR,"I"))
. S DIC=5,DA=+VAPA(5),DR=3,DR(5.01)=2,DA(5.01)=+VAPA(7),DIQ="ECXAR"
. S DIQ(0)="I" D EN^DIQ1
. S ECXPAT("COUNTY")=$G(ECXAR(5.01,DA(5.01),2,"I"))
. S ECXPAT("ZIP")=$P(VAPA(11),U,2)
. S ECXPAT("COUNTRY")=$$GET1^DIQ(779.004,+$P($G(VAPA(25)),U),.01)
. S ECXPAT=1
D ;get eligibility information
. I ECXDATA'="",'$D(ECXCOD(3)) Q
. D ELIG^VADPT
. S PELG=$P(VAEL(1),U),MELIG=$S(PELG="":"",1:$$GET1^DIQ(8,PELG,8,"I"))
. S ECXPAT("POS")=$P($G(^DIC(21,+VAEL(2),0)),U,3)
. S ECXPAT("SC STAT")=$S(+VAEL(3):"Y",+VAEL(3)=0:"N",1:"")
. S ECXPAT("SC%")=$P(VAEL(3),U,2)
. S ECXPAT("VET")=$S(VAEL(4):"Y",VAEL(4)=0:"N",1:"")
. S ECXPAT("MEANS")=$P(VAEL(9),U),ECXPAT=1
. S ECXPAT("ELIG")=$$ELIG(MELIG,ECXPAT("SC%"))
. ;get enrollment location
. S DIC=2,DR=27.02,DA=ECXDFN,DIQ="ECXAR",DIQ(0)="I" D EN^DIQ1
. S ECXDAT=$G(ECXAR(2,ECXDFN,DR,"I")) I ECXDAT K ECXAR D
. . S DIC=4,DA=ECXDAT,DR=99,DIQ="ECXAR",DIQ(0)="I" D EN^DIQ1
. . S ECXPAT("ENROLL LOC")=ECXAR(4,ECXDAT,DR,"I")
. ;get Emergency Response Indicator (FEMA)
. S ECXPAT("ERI")=$$GET1^DIQ(2,ECXDFN,.181,"I")
D ;get other patient information
. I ECXDATA'="",'$D(ECXCOD(4)) Q
. D OPD^VADPT
. S ECXPAT("EMPLOY")=$P(VAPD(7),U),ECXPAT=1
D ;get service information
. I ECXDATA'="",'$D(ECXCOD(5)) Q
. D SVC^VADPT
. S ECXPAT("VIETNAM")=$S(VASV(1):"Y",VASV(1)=0:"N",1:"U") ;149
. S ECXPAT("AO STAT")=$S(VASV(2):"Y",VASV(2)=0:"N",1:"U")
. S ECXPAT("IR STAT")=$S(VASV(3):"Y",VASV(3)=0:"N",1:"U")
. I $G(ECXLOGIC)>2017 S ECXPAT("IR STAT")=$S(VASV(3):$P($G(VASV(3,2)),U),VASV(3)=0:"1",1:"U")
. S ECXPAT("EC STAT")=$$GET1^DIQ(2,ECXDFN,.322013,"I")
. S ECXPAT("POW STAT")=$S(VASV(4):"Y",VASV(4)=0:"N",1:"U")
. S ECXPAT("POW LOC")=$P(VASV(4,3),U),ECXPAT=1
. S ECXPAT("PHI")=$S(VASV(9)=1:"Y",VASV(9)=0:"N",1:"")
. S ECXPAT("CL STAT")=$S($G(VASV(15)):"Y",$G(VASV(15))=0:"N",1:"") ;144,149 Camp Lejeune status will be in VASV(15) when SVC^VADPT provides it
. ;- Agent Orange Location (K=Korean DMZ,V=Vietnam)
. S ECXPAT("AOL")=$P($G(VASV(2,5)),U)
. S ECXPAT("COMBSVCI")=$S(VASV(5):"Y",VASV(5)=0:"N",1:"") ;149 COMBAT SVC IND
. S ECXPAT("COMBSVCL")=$$GET1^DIQ(22,$P($G(VASV(5,3)),"^"),1) ;149 COMBAT SVC LOC USE ABBR
. ;get patient OEF/OIF status and date of return
. D OEFDATA^ECXUTL4
. ;
. ;get patient current MST status
. I ECXDATE'="",ECXDATE'["." S ECXDATE=ECXDATE+.9
. S X="DGMSTAPI" X ^%ZOSF("TEST") I $T D
. . S ECXDAT=$$GETSTAT^DGMSTAPI(DFN,ECXDATE)
. . S ECXPAT("MST STAT")=$S(+ECXDAT>0:$P(ECXDAT,U,2),1:"")
I 'ECXPAT K ECXPAT Q 0
Q 1
;
ELIG(ECXELIG,ECXSVCP) ;Converts veteran eligibility code to NPCD code
; Variables -
; Input ECXELIG - Pointer to MAS ELIGIBILITY CODE file #8.1
; ECXSVCP - Number value rep. service connected percentage.
;
; Output:
; ECXNCPD NPCD Eligibility Code
;
N TEXT,IEN,SCPER,FND,NPCD,I,ECXBG,ECXEN,ECXNPCD
I ECXELIG="" Q ""
F I=1:1 S TEXT=$P($T(ELGTXT+I),";",3,999) Q:TEXT="END" D I $D(NPCD) Q
. S IEN=$P(TEXT,";"),SCPER=$P(TEXT,";",2)
. I ECXELIG=IEN D
. . I SCPER="" S NPCD=$P(TEXT,";",3) Q
. . S ECXBG=$S($E(SCPER)="<":0,$E(SCPER)=">":$P(SCPER,">",2)+1,SCPER["-":+SCPER,1:"")
. . S ECXEN=$S($E(SCPER)="<":$P(SCPER,"<",2),$E(SCPER)=">":100,SCPER["-":$P(SCPER,"-",2),1:"")
. . I ECXSVCP'<ECXBG,ECXSVCP'>ECXEN S NPCD=$P(TEXT,";",3)
S ECXNPCD=$G(NPCD)
Q ECXNPCD
ELGTXT ;Eligibility codes
;;1;>49;10;SC 50-100%
;;2;;20;Aid & Attendance
;;15;;21;Housebound
;;16;;22;Mexican Border War
;;17;;23;WWI
;;18;;24;POW
;;3;40-49;30;SC 40-49%
;;3;30-39;31;SC 30-39%
;;3;20-29;32;SC 20-29%
;;3;10-19;33;SC 10-19%
;;3;<10;34;SC less than 10%
;;4;;40;NSC - VA Pension
;;5;;50;NSC
;;21;;60;Catastrophic Disability
;;12;;101;CHAMPVA
;;13;;102;Collateral of Veteran
;;14;;103;Employee
;;6;;104;Other Federal Agency
;;7;;105;Allied Veteran
;;8;;106;Humanitarian Emergency
;;9;;107;Sharing Agreement
;;10;;108;Reimbursable Insurance
;;19;;109;TRICARE/CHAMPUS
;;22;;25;Purple Heart Recipient
;;END
;
CPT(ECXCPT,ECXMOD,ECXQUA) ;Returns a str with CPT code and modifier codes
;Return string is composed of a 5 character CPT code 2 character quantity
;plus up to 5 modifier codes, 2 characters each.
; Variables -
; Input ECXCPT - Pointer value to the CPT file (#81)
; ECXMOD - A string with pointer values to the CPT
; MODIFIER file (#81.3) separated by ";"
; ECXQUA - Number of time this procedure performed
;
; Output:
; CPTMOD - String of up to 17 characters, 5 character CPT
; code 2 character qty plus up to 5 2-character
; code modifiers.
;
N CPT,MOD,I,CPTMOD
S ECXQUA=$G(ECXQUA,"01"),ECXMOD=$G(ECXMOD)
S:$L(ECXQUA)'=2 ECXQUA="0"_ECXQUA
S CPT=$$CPT^ICPTCOD(ECXCPT,"") I +CPT=-1 Q ""
S CPT=$P(CPT,U,2)_ECXQUA
F I=1:1:99 I $P(ECXMOD,";",I)'="" D
. S MOD=$$MOD^ICPTMOD($P(ECXMOD,";",I),"I","")
. I +MOD>0,$P(MOD,U,2)'="99" S CPT=CPT_$P(MOD,U,2)
S CPTMOD=$TR($E(CPT,1,17)," ")
Q CPTMOD
;
CPT3Q6M(ECXCPT,ECXMOD,ECXQUA) ;
;
; This API was created for patch 170 (FY19) to handle 3-digit quantities
; and up to 6 modifiers.
;
; Return string is composed of a 5-character CPT code, 3-character quantity
; and up to 6 2-character modifier codes.
;
; Variables -
; Input ECXCPT - Pointer value to the CPT file (#81)
; ECXMOD - A string with pointer values to the CPT
; MODIFIER file (#81.3) separated by ";"
; ECXQUA - Number of times this procedure was performed
;
; Output:
; CPTMOD - String of up to 20 characters - a 5-character CPT
; code, 3-character quantity, and up to 6 2-character
; code modifiers.
;
N CPT,MOD,I,CPTMOD,LEN
S ECXQUA=$G(ECXQUA,"001"),ECXMOD=$G(ECXMOD)
F LEN=1,2 I $L(ECXQUA)=LEN S ECXQUA="0"_ECXQUA
S CPT=$$CPT^ICPTCOD(ECXCPT,"") I +CPT=-1 Q ""
S CPT=$P(CPT,U,2)_ECXQUA
F I=1:1:99 I $P(ECXMOD,";",I)'="" D
. S MOD=$$MOD^ICPTMOD($P(ECXMOD,";",I),"I","")
. I +MOD>0,$P(MOD,U,2)'="99" S CPT=CPT_$P(MOD,U,2)
S CPTMOD=$TR($E(CPT,1,20)," ")
Q CPTMOD
CPTOUT(ECXCPT) ;output transform for CPT code plus modifiers
;input ECXCPT - character string of CPT code plus modifiers (required)
;
N J,CPTX,MOD,MODS,MODX,CPTMOD
Q:$G(ECXCPT)="" ""
S (CPTMOD,MODX)=""
S CPTX="("_+$E(ECXCPT,6,7)_") "_$E(ECXCPT,1,5),MODS=$E(ECXCPT,8,17)
F J=1:2:9 S MOD=$E(MODS,J,J+1) Q:MOD="" D
.I J>1 S MODX=MODX_", "_MOD Q
.S MODX=MODX_"-"_MOD
S:$L(CPTX)>3 CPTMOD=CPTMOD_CPTX_MODX
Q CPTMOD
;
CHECKRC(RACEIEN) ;144 API added to check RACE for non-stardard values that can be converted. If the value can be converted then it will be stored in RACE1 upon return
N NAME,DIC,X,Y,PTFVAL
S NAME=$$PTR2TEXT^DGUTL4(RACEIEN)
S PTFVAL=""
I NAME="AMER INDIAN OR ALASKAN NATIVE"!(NAME="AMERICAN INDIAN")!(NAME="AMERICAN INDIAN/ALASKAN NATIVE")!(NAME="AMERICAN INDIAN OR ALASKAN NATIVE") S X="AMERICAN INDIAN OR ALASKA NATIVE"
I NAME="AMERICAN INDIAN/ALASKA NATIVE"!(NAME="AMERICAN INDIAN/ALASKAN")!(NAME="AMERICAN INDIANT OR ALASKA NATIVE") S X="AMERICAN INDIAN OR ALASKA NATIVE"
I NAME="BLACK"!(NAME="BLACK NOT OF HISP ORIG")!(NAME="BLACK, NON HISPANIC")!(NAME="BLACK, NOT OF HISPANIC ORIGIN") S X="BLACK OR AFRICAN AMERICAN"
I NAME="BLACK,NOT OF HISPANIC ORIGIN"!(NAME="HISPANIC BLACK")!(NAME="HISPANIC, BLACK")!(NAME="HISPANIC,BLACK") S X="BLACK OR AFRICAN AMERICAN"
I NAME="WHITE NOT OF HISP ORIG"!(NAME="WHITE, NON HISPANIC")!(NAME="WHITE, NOT OF HISPANIC")!(NAME="WHITE, NOT OF HISPANIC ORIGIN")!(NAME="WHITE,NOT OF HISPANIC ORIGIN") S X="WHITE"
I NAME="CAUCASIAN"!(NAME="CAUCASIAN, NOT OF HISPANIC ORIGIN")!(NAME="HISPANIC WHITE")!(NAME="HISPANIC, WHITE")!(NAME="HISPANIC,WHITE") S X="WHITE"
I NAME="PACIFIC ISLANDER" S X="NATIVE HAWAIIAN OR OTHER PACIFIC ISLANDER"
S DIC(0)="MQ",DIC=10 D ^DIC ;Find standard race in RACE file
I Y S PTFVAL=$$PTR2CODE^DGUTL4(+Y,1,4) ;If found, get PTF value to return
Q PTFVAL
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HECXUTL3 13818 printed Oct 16, 2024@17:55:09 Page 2
ECXUTL3 ;ALB/GTS - Utilities for DSS Extracts ;9/4/18 13:18
+1 ;;3.0;DSS EXTRACTS;**11,24,32,33,35,37,39,42,46,92,105,120,144,149,154,166,170,184,187**;Dec 22,1997;Build 163
+2 ;
+3 ; Reference to ^DPT( in ICR #1850
+4 ; Reference to $$GETSTAT^DGMSTAPI in ICR #2716
+5 ; Reference to $$PTR2CODE^DGUTL4,$$PTR2TEXT^DGUTL4 in ICR #3799
+6 ;
OUTPTTM(ECXDFN,ECXDT) ;* Return PC Team from PCMM files or DPT
+1 ; Variables -
+2 ; ECXDFN - IEN from Patient file (Required)
+3 ; ECXDT - Relevant Date for Primary Care Team
+4 ; (Defaults to DT)
+5 ;
+6 ; Returned: ECXTM -
+7 ; Pointer to team file (#404.51)
+8 ; or, if error or none defined, returns 0
+9 ;
+10 ;** Quit if ECXDFN not defined
if '$GET(ECXDFN)
QUIT 0
+11 NEW ECXTM
+12 if '$DATA(ECXDT)
SET ECXDT=DT
+13 IF $TEXT(OUTPTTM^SDUTL3)[",SCDATE"
Begin DoDot:1
+14 SET ECXTM=+$$OUTPTTM^SDUTL3(ECXDFN,ECXDT)
End DoDot:1
+15 IF $TEXT(OUTPTTM^SDUTL3)'[",SCDATE"
Begin DoDot:1
+16 SET ECXTM=+$$OUTPTTM^SDUTL3(ECXDFN)
End DoDot:1
+17 IF ECXTM=0
Begin DoDot:1
+18 SET ECXTM=+$PIECE($GET(^DPT(+ECXDFN,"PC")),U,2)
End DoDot:1
+19 QUIT ECXTM
+20 ;
OUTPTPR(ECXDFN,ECXDT) ;* Return PC Provider from PCMM files or DPT
+1 ; Variables -
+2 ; ECXDFN - IEN from Patient file (Required)
+3 ; ECXDT - Relevant Date for Primary Care Provider
+4 ; (Defaults to DT)
+5 ;
+6 ; Returned: ECXPR -
+7 ; Pointer to file #200
+8 ; or, if error or none defined, returns a 0
+9 ;
+10 ;** Quit if ECXDFN not defined
if '$GET(ECXDFN)
QUIT 0
+11 NEW ECXPR
+12 if '$DATA(ECXDT)
SET ECXDT=DT
+13 IF $TEXT(OUTPTPR^SDUTL3)[",SCDATE"
Begin DoDot:1
+14 SET ECXPR=+$$OUTPTPR^SDUTL3(ECXDFN,ECXDT)
End DoDot:1
+15 IF $TEXT(OUTPTPR^SDUTL3)'[",SCDATE"
Begin DoDot:1
+16 SET ECXPR=+$$OUTPTPR^SDUTL3(ECXDFN)
End DoDot:1
+17 IF ECXPR=0
Begin DoDot:1
+18 SET ECXPR=+$GET(^DPT(+ECXDFN,"PC"))
End DoDot:1
+19 QUIT ECXPR
+20 ;
PAT(ECXDFN,ECXDATE,ECXDATA,ECXPAT) ;Return basic patient data for extract
+1 ; Will not return data associated with test patients (SSN begin w 00000)
+2 ; Variables -
+3 ; Input ECXDFN - Patient internal entry number, DFN file#2; required
+4 ; ECXDATE- Date used to get specific data from GETSTAT^DGMSTAPI
+5 ; for MST. If no date, defaults to today's date,
+6 ; standard FM format, optional
+7 ; ECXDATA- Code indicating which data to return, optional.
+8 ; If code not specified then returns all. Codes are:
+9 ; 1 - DEM^VADPT (demographic data)
+10 ; 2 - ADD^VADPT (current address)
+11 ; 3 - ELIG^VADPT (eligibility & enrollment location)
+12 ; 4 - OPD^VADPT (other patient data)
+13 ; 5 - SVC^VADPT & GETSTAT^DGMSTAPI (service & MST inf)
+14 ; ECXPAT(- Passed by reference; required
+15 ;
+16 ; Output:
+17 ; ECXPAT 0 error or test patient no data in ECXPAT array
+18 ; 1 data returned in ECXPAT array
+19 ; ECXPAT( Local array with patient data.
+20 ;
+21 NEW SSN,I,ECXCOD,ECXDAT,DFN,VAPA,VADM,VAEL,VAPD,VASV,STR,ECXAR,DIC,DIQ,RCNUM,RCVAL,COLMETH
+22 ;187 Added PTNAME
NEW DA,DR,PELG,MELIG,ZIP,MPI,PTNAME
+23 IF ECXDFN=""
QUIT 0
+24 ;187
SET PTNAME=$$GET1^DIQ(2,ECXDFN,.01,"I")
+25 ;187 - exclude patient whose name started with "ZZ"
IF $EXTRACT(PTNAME,1,2)="ZZ"
QUIT 0
+26 SET SSN=$$GET1^DIQ(2,ECXDFN,.09,"I")
SET DFN=ECXDFN
SET ECXPAT=0
+27 ;I $E(SSN,1,3)="000"!(SSN="") K ECXPAT Q 0 ;154 removed as these checks are done in ECXUTL5 ;test patient
+28 ;test patient extended checks; mtl extract excluded
+29 ;154 modified section for SSN testing
IF $GET(ECHEAD)'="MTL"
Begin DoDot:1
+30 ;154 If event capture extract and 5 leading zeroes test patient and workload is CH103 to CH109 then allow test SSN
IF $GET(ECHEAD)="ECS"
IF $EXTRACT(SSN,1,5)="00000"
IF "^CH103^CH104^CH105^CH106^CH107^CH108^CH109^"[("^"_$GET(ECPNM)_"^")
QUIT
+31 IF '$$SSN^ECXUTL5(SSN)
KILL ECXPAT
End DoDot:1
IF $GET(ECXPAT)=""
QUIT 0
+32 SET STR="NAME;SSN;DOB;SEX;RACE;RELIGION;STATE;COUNTY;ZIP;SC%;MEANS;ELIG;"
+33 SET STR=STR_"EMPLOY;AO STAT;IR STAT;EC STAT;POW STAT;POW LOC;MST STAT;"
+34 ;149 COMB SVS IND,LOC
SET STR=STR_"ENROLL LOC;MPI;VIETNAM;POS;MARITAL;CL STAT;COMBSVCI;COMBSVCL"
+35 ;initialize return array values
+36 FOR I=1:1
SET ECXDAT=$PIECE(STR,";",I)
if ECXDAT=""
QUIT
SET ECXPAT(ECXDAT)=""
+37 FOR I=1:1:$LENGTH(ECXDATA,";")
SET ECXDAT=$PIECE(ECXDATA,";",I)
IF ECXDAT'=""
Begin DoDot:1
+38 SET ECXCOD(ECXDAT)=""
End DoDot:1
+39 ;
+40 ;- Get ICN if MPI installed
+41 SET X="MPIF001"
XECUTE ^%ZOSF("TEST")
IF $TEST
Begin DoDot:1
+42 ;
+43 ;- Get 1st piece (either ICN # or -1 if error)
+44 ;184 - Removed "+" to include the check sum
SET MPI=$$GETICN^MPIF001(DFN)
+45 ;
+46 ;- If error, set to null
+47 SET ECXPAT("MPI")=$SELECT(MPI>0:MPI,1:"")
End DoDot:1
+48 ;get demographic data
Begin DoDot:1
+49 IF ECXDATA'=""
IF '$DATA(ECXCOD(1))
QUIT
+50 DO DEM^VADPT
+51 SET ECXPAT("NAME")=$EXTRACT($PIECE(VADM(1),",")_" ",1,4)
+52 SET ECXPAT("SSN")=$PIECE(VADM(2),U)
SET ECXPAT("MARITAL")=$PIECE(VADM(10),U)
+53 SET ECXPAT("DOB")=$$ECXDOB^ECXUTL($PIECE(VADM(3),U))
+54 SET ECXPAT("SEX")=$PIECE(VADM(5),U)
SET ECXPAT("RELIGION")=$PIECE(VADM(9),U)
+55 ;184 - Add SIGI Code
SET ECXPAT("SIGI")=$PIECE(VADM(14,5),U,2)
+56 SET DIC=10
SET DR=2
SET DA=+VADM(8)
SET DIQ="ECXAR"
SET DIQ(0)="I"
DO EN^DIQ1
+57 SET ECXPAT("RACE")=$GET(ECXAR(10,DA,DR,"I"))
SET ECXPAT=1
+58 ;add new race and ethnicity fields for FY2003
+59 SET (ECXPAT("ETHNIC"),ECXPAT("RACE1"))=""
+60 SET X="DGUTL4"
XECUTE ^%ZOSF("TEST")
IF $TEST
Begin DoDot:2
+61 SET COLMETH=$$PTR2CODE^DGUTL4($GET(VADM(11,1,1)),3,4)
IF COLMETH="S"
Begin DoDot:3
+62 SET ECXPAT("ETHNIC")=$$PTR2CODE^DGUTL4(+$GET(VADM(11,1)),2,4)
End DoDot:3
+63 SET (RCVAL,RCNUM)=""
+64 FOR
SET RCNUM=$ORDER(VADM(12,RCNUM))
if RCNUM=""
QUIT
if RCVAL="C"
QUIT
SET COLMETH=$$PTR2CODE^DGUTL4(+$GET(VADM(12,RCNUM,1)),3,4)
IF COLMETH="S"
Begin DoDot:3
+65 SET RCVAL=$$PTR2CODE^DGUTL4(+$GET(VADM(12,RCNUM)),1,4)
+66 IF RCVAL="C"
SET ECXPAT("RACE1")=RCVAL
QUIT
+67 SET ECXPAT("RACE1")=ECXPAT("RACE1")_RCVAL
End DoDot:3
End DoDot:2
+68 ;144 If RACE1 is null, check value in RACE field
IF ECXPAT("RACE1")=""
SET ECXPAT("RACE1")=$$CHECKRC(+VADM(8))
End DoDot:1
+69 ;get address information
Begin DoDot:1
+70 IF ECXDATA'=""
IF '$DATA(ECXCOD(2))
QUIT
+71 DO ADD^VADPT
+72 SET DIC=5
SET DR=2
SET DA=+VAPA(5)
SET DIQ="ECXAR"
SET DIQ(0)="I"
DO EN^DIQ1
+73 SET ECXPAT("STATE")=$GET(ECXAR(5,DA,DR,"I"))
+74 SET DIC=5
SET DA=+VAPA(5)
SET DR=3
SET DR(5.01)=2
SET DA(5.01)=+VAPA(7)
SET DIQ="ECXAR"
+75 SET DIQ(0)="I"
DO EN^DIQ1
+76 SET ECXPAT("COUNTY")=$GET(ECXAR(5.01,DA(5.01),2,"I"))
+77 SET ECXPAT("ZIP")=$PIECE(VAPA(11),U,2)
+78 SET ECXPAT("COUNTRY")=$$GET1^DIQ(779.004,+$PIECE($GET(VAPA(25)),U),.01)
+79 SET ECXPAT=1
End DoDot:1
+80 ;get eligibility information
Begin DoDot:1
+81 IF ECXDATA'=""
IF '$DATA(ECXCOD(3))
QUIT
+82 DO ELIG^VADPT
+83 SET PELG=$PIECE(VAEL(1),U)
SET MELIG=$SELECT(PELG="":"",1:$$GET1^DIQ(8,PELG,8,"I"))
+84 SET ECXPAT("POS")=$PIECE($GET(^DIC(21,+VAEL(2),0)),U,3)
+85 SET ECXPAT("SC STAT")=$SELECT(+VAEL(3):"Y",+VAEL(3)=0:"N",1:"")
+86 SET ECXPAT("SC%")=$PIECE(VAEL(3),U,2)
+87 SET ECXPAT("VET")=$SELECT(VAEL(4):"Y",VAEL(4)=0:"N",1:"")
+88 SET ECXPAT("MEANS")=$PIECE(VAEL(9),U)
SET ECXPAT=1
+89 SET ECXPAT("ELIG")=$$ELIG(MELIG,ECXPAT("SC%"))
+90 ;get enrollment location
+91 SET DIC=2
SET DR=27.02
SET DA=ECXDFN
SET DIQ="ECXAR"
SET DIQ(0)="I"
DO EN^DIQ1
+92 SET ECXDAT=$GET(ECXAR(2,ECXDFN,DR,"I"))
IF ECXDAT
KILL ECXAR
Begin DoDot:2
+93 SET DIC=4
SET DA=ECXDAT
SET DR=99
SET DIQ="ECXAR"
SET DIQ(0)="I"
DO EN^DIQ1
+94 SET ECXPAT("ENROLL LOC")=ECXAR(4,ECXDAT,DR,"I")
End DoDot:2
+95 ;get Emergency Response Indicator (FEMA)
+96 SET ECXPAT("ERI")=$$GET1^DIQ(2,ECXDFN,.181,"I")
End DoDot:1
+97 ;get other patient information
Begin DoDot:1
+98 IF ECXDATA'=""
IF '$DATA(ECXCOD(4))
QUIT
+99 DO OPD^VADPT
+100 SET ECXPAT("EMPLOY")=$PIECE(VAPD(7),U)
SET ECXPAT=1
End DoDot:1
+101 ;get service information
Begin DoDot:1
+102 IF ECXDATA'=""
IF '$DATA(ECXCOD(5))
QUIT
+103 DO SVC^VADPT
+104 ;149
SET ECXPAT("VIETNAM")=$SELECT(VASV(1):"Y",VASV(1)=0:"N",1:"U")
+105 SET ECXPAT("AO STAT")=$SELECT(VASV(2):"Y",VASV(2)=0:"N",1:"U")
+106 SET ECXPAT("IR STAT")=$SELECT(VASV(3):"Y",VASV(3)=0:"N",1:"U")
+107 IF $GET(ECXLOGIC)>2017
SET ECXPAT("IR STAT")=$SELECT(VASV(3):$PIECE($GET(VASV(3,2)),U),VASV(3)=0:"1",1:"U")
+108 SET ECXPAT("EC STAT")=$$GET1^DIQ(2,ECXDFN,.322013,"I")
+109 SET ECXPAT("POW STAT")=$SELECT(VASV(4):"Y",VASV(4)=0:"N",1:"U")
+110 SET ECXPAT("POW LOC")=$PIECE(VASV(4,3),U)
SET ECXPAT=1
+111 SET ECXPAT("PHI")=$SELECT(VASV(9)=1:"Y",VASV(9)=0:"N",1:"")
+112 ;144,149 Camp Lejeune status will be in VASV(15) when SVC^VADPT provides it
SET ECXPAT("CL STAT")=$SELECT($GET(VASV(15)):"Y",$GET(VASV(15))=0:"N",1:"")
+113 ;- Agent Orange Location (K=Korean DMZ,V=Vietnam)
+114 SET ECXPAT("AOL")=$PIECE($GET(VASV(2,5)),U)
+115 ;149 COMBAT SVC IND
SET ECXPAT("COMBSVCI")=$SELECT(VASV(5):"Y",VASV(5)=0:"N",1:"")
+116 ;149 COMBAT SVC LOC USE ABBR
SET ECXPAT("COMBSVCL")=$$GET1^DIQ(22,$PIECE($GET(VASV(5,3)),"^"),1)
+117 ;get patient OEF/OIF status and date of return
+118 DO OEFDATA^ECXUTL4
+119 ;
+120 ;get patient current MST status
+121 IF ECXDATE'=""
IF ECXDATE'["."
SET ECXDATE=ECXDATE+.9
+122 SET X="DGMSTAPI"
XECUTE ^%ZOSF("TEST")
IF $TEST
Begin DoDot:2
+123 SET ECXDAT=$$GETSTAT^DGMSTAPI(DFN,ECXDATE)
+124 SET ECXPAT("MST STAT")=$SELECT(+ECXDAT>0:$PIECE(ECXDAT,U,2),1:"")
End DoDot:2
End DoDot:1
+125 IF 'ECXPAT
KILL ECXPAT
QUIT 0
+126 QUIT 1
+127 ;
ELIG(ECXELIG,ECXSVCP) ;Converts veteran eligibility code to NPCD code
+1 ; Variables -
+2 ; Input ECXELIG - Pointer to MAS ELIGIBILITY CODE file #8.1
+3 ; ECXSVCP - Number value rep. service connected percentage.
+4 ;
+5 ; Output:
+6 ; ECXNCPD NPCD Eligibility Code
+7 ;
+8 NEW TEXT,IEN,SCPER,FND,NPCD,I,ECXBG,ECXEN,ECXNPCD
+9 IF ECXELIG=""
QUIT ""
+10 FOR I=1:1
SET TEXT=$PIECE($TEXT(ELGTXT+I),";",3,999)
if TEXT="END"
QUIT
Begin DoDot:1
+11 SET IEN=$PIECE(TEXT,";")
SET SCPER=$PIECE(TEXT,";",2)
+12 IF ECXELIG=IEN
Begin DoDot:2
+13 IF SCPER=""
SET NPCD=$PIECE(TEXT,";",3)
QUIT
+14 SET ECXBG=$SELECT($EXTRACT(SCPER)="<":0,$EXTRACT(SCPER)=">":$PIECE(SCPER,">",2)+1,SCPER["-":+SCPER,1:"")
+15 SET ECXEN=$SELECT($EXTRACT(SCPER)="<":$PIECE(SCPER,"<",2),$EXTRACT(SCPER)=">":100,SCPER["-":$PIECE(SCPER,"-",2),1:"")
+16 IF ECXSVCP'<ECXBG
IF ECXSVCP'>ECXEN
SET NPCD=$PIECE(TEXT,";",3)
End DoDot:2
End DoDot:1
IF $DATA(NPCD)
QUIT
+17 SET ECXNPCD=$GET(NPCD)
+18 QUIT ECXNPCD
ELGTXT ;Eligibility codes
+1 ;;1;>49;10;SC 50-100%
+2 ;;2;;20;Aid & Attendance
+3 ;;15;;21;Housebound
+4 ;;16;;22;Mexican Border War
+5 ;;17;;23;WWI
+6 ;;18;;24;POW
+7 ;;3;40-49;30;SC 40-49%
+8 ;;3;30-39;31;SC 30-39%
+9 ;;3;20-29;32;SC 20-29%
+10 ;;3;10-19;33;SC 10-19%
+11 ;;3;<10;34;SC less than 10%
+12 ;;4;;40;NSC - VA Pension
+13 ;;5;;50;NSC
+14 ;;21;;60;Catastrophic Disability
+15 ;;12;;101;CHAMPVA
+16 ;;13;;102;Collateral of Veteran
+17 ;;14;;103;Employee
+18 ;;6;;104;Other Federal Agency
+19 ;;7;;105;Allied Veteran
+20 ;;8;;106;Humanitarian Emergency
+21 ;;9;;107;Sharing Agreement
+22 ;;10;;108;Reimbursable Insurance
+23 ;;19;;109;TRICARE/CHAMPUS
+24 ;;22;;25;Purple Heart Recipient
+25 ;;END
+26 ;
CPT(ECXCPT,ECXMOD,ECXQUA) ;Returns a str with CPT code and modifier codes
+1 ;Return string is composed of a 5 character CPT code 2 character quantity
+2 ;plus up to 5 modifier codes, 2 characters each.
+3 ; Variables -
+4 ; Input ECXCPT - Pointer value to the CPT file (#81)
+5 ; ECXMOD - A string with pointer values to the CPT
+6 ; MODIFIER file (#81.3) separated by ";"
+7 ; ECXQUA - Number of time this procedure performed
+8 ;
+9 ; Output:
+10 ; CPTMOD - String of up to 17 characters, 5 character CPT
+11 ; code 2 character qty plus up to 5 2-character
+12 ; code modifiers.
+13 ;
+14 NEW CPT,MOD,I,CPTMOD
+15 SET ECXQUA=$GET(ECXQUA,"01")
SET ECXMOD=$GET(ECXMOD)
+16 if $LENGTH(ECXQUA)'=2
SET ECXQUA="0"_ECXQUA
+17 SET CPT=$$CPT^ICPTCOD(ECXCPT,"")
IF +CPT=-1
QUIT ""
+18 SET CPT=$PIECE(CPT,U,2)_ECXQUA
+19 FOR I=1:1:99
IF $PIECE(ECXMOD,";",I)'=""
Begin DoDot:1
+20 SET MOD=$$MOD^ICPTMOD($PIECE(ECXMOD,";",I),"I","")
+21 IF +MOD>0
IF $PIECE(MOD,U,2)'="99"
SET CPT=CPT_$PIECE(MOD,U,2)
End DoDot:1
+22 SET CPTMOD=$TRANSLATE($EXTRACT(CPT,1,17)," ")
+23 QUIT CPTMOD
+24 ;
CPT3Q6M(ECXCPT,ECXMOD,ECXQUA) ;
+1 ;
+2 ; This API was created for patch 170 (FY19) to handle 3-digit quantities
+3 ; and up to 6 modifiers.
+4 ;
+5 ; Return string is composed of a 5-character CPT code, 3-character quantity
+6 ; and up to 6 2-character modifier codes.
+7 ;
+8 ; Variables -
+9 ; Input ECXCPT - Pointer value to the CPT file (#81)
+10 ; ECXMOD - A string with pointer values to the CPT
+11 ; MODIFIER file (#81.3) separated by ";"
+12 ; ECXQUA - Number of times this procedure was performed
+13 ;
+14 ; Output:
+15 ; CPTMOD - String of up to 20 characters - a 5-character CPT
+16 ; code, 3-character quantity, and up to 6 2-character
+17 ; code modifiers.
+18 ;
+19 NEW CPT,MOD,I,CPTMOD,LEN
+20 SET ECXQUA=$GET(ECXQUA,"001")
SET ECXMOD=$GET(ECXMOD)
+21 FOR LEN=1,2
IF $LENGTH(ECXQUA)=LEN
SET ECXQUA="0"_ECXQUA
+22 SET CPT=$$CPT^ICPTCOD(ECXCPT,"")
IF +CPT=-1
QUIT ""
+23 SET CPT=$PIECE(CPT,U,2)_ECXQUA
+24 FOR I=1:1:99
IF $PIECE(ECXMOD,";",I)'=""
Begin DoDot:1
+25 SET MOD=$$MOD^ICPTMOD($PIECE(ECXMOD,";",I),"I","")
+26 IF +MOD>0
IF $PIECE(MOD,U,2)'="99"
SET CPT=CPT_$PIECE(MOD,U,2)
End DoDot:1
+27 SET CPTMOD=$TRANSLATE($EXTRACT(CPT,1,20)," ")
+28 QUIT CPTMOD
CPTOUT(ECXCPT) ;output transform for CPT code plus modifiers
+1 ;input ECXCPT - character string of CPT code plus modifiers (required)
+2 ;
+3 NEW J,CPTX,MOD,MODS,MODX,CPTMOD
+4 if $GET(ECXCPT)=""
QUIT ""
+5 SET (CPTMOD,MODX)=""
+6 SET CPTX="("_+$EXTRACT(ECXCPT,6,7)_") "_$EXTRACT(ECXCPT,1,5)
SET MODS=$EXTRACT(ECXCPT,8,17)
+7 FOR J=1:2:9
SET MOD=$EXTRACT(MODS,J,J+1)
if MOD=""
QUIT
Begin DoDot:1
+8 IF J>1
SET MODX=MODX_", "_MOD
QUIT
+9 SET MODX=MODX_"-"_MOD
End DoDot:1
+10 if $LENGTH(CPTX)>3
SET CPTMOD=CPTMOD_CPTX_MODX
+11 QUIT CPTMOD
+12 ;
CHECKRC(RACEIEN) ;144 API added to check RACE for non-stardard values that can be converted. If the value can be converted then it will be stored in RACE1 upon return
+1 NEW NAME,DIC,X,Y,PTFVAL
+2 SET NAME=$$PTR2TEXT^DGUTL4(RACEIEN)
+3 SET PTFVAL=""
+4 IF NAME="AMER INDIAN OR ALASKAN NATIVE"!(NAME="AMERICAN INDIAN")!(NAME="AMERICAN INDIAN/ALASKAN NATIVE")!(NAME="AMERICAN INDIAN OR ALASKAN NATIVE")
SET X="AMERICAN INDIAN OR ALASKA NATIVE"
+5 IF NAME="AMERICAN INDIAN/ALASKA NATIVE"!(NAME="AMERICAN INDIAN/ALASKAN")!(NAME="AMERICAN INDIANT OR ALASKA NATIVE")
SET X="AMERICAN INDIAN OR ALASKA NATIVE"
+6 IF NAME="BLACK"!(NAME="BLACK NOT OF HISP ORIG")!(NAME="BLACK, NON HISPANIC")!(NAME="BLACK, NOT OF HISPANIC ORIGIN")
SET X="BLACK OR AFRICAN AMERICAN"
+7 IF NAME="BLACK,NOT OF HISPANIC ORIGIN"!(NAME="HISPANIC BLACK")!(NAME="HISPANIC, BLACK")!(NAME="HISPANIC,BLACK")
SET X="BLACK OR AFRICAN AMERICAN"
+8 IF NAME="WHITE NOT OF HISP ORIG"!(NAME="WHITE, NON HISPANIC")!(NAME="WHITE, NOT OF HISPANIC")!(NAME="WHITE, NOT OF HISPANIC ORIGIN")!(NAME="WHITE,NOT OF HISPANIC ORIGIN")
SET X="WHITE"
+9 IF NAME="CAUCASIAN"!(NAME="CAUCASIAN, NOT OF HISPANIC ORIGIN")!(NAME="HISPANIC WHITE")!(NAME="HISPANIC, WHITE")!(NAME="HISPANIC,WHITE")
SET X="WHITE"
+10 IF NAME="PACIFIC ISLANDER"
SET X="NATIVE HAWAIIAN OR OTHER PACIFIC ISLANDER"
+11 ;Find standard race in RACE file
SET DIC(0)="MQ"
SET DIC=10
DO ^DIC
+12 ;If found, get PTF value to return
IF Y
SET PTFVAL=$$PTR2CODE^DGUTL4(+Y,1,4)
+13 QUIT PTFVAL
