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

ECXUTL3.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. ; Reference to ^DPT( in ICR #1850
  1. ; Reference to $$GETSTAT^DGMSTAPI in ICR #2716
  1. ; Reference to $$PTR2CODE^DGUTL4,$$PTR2TEXT^DGUTL4 in ICR #3799
  1. ;
  1. OUTPTTM(ECXDFN,ECXDT) ;* Return PC Team from PCMM files or DPT
  1. ; Variables -
  1. ; ECXDFN - IEN from Patient file (Required)
  1. ; ECXDT - Relevant Date for Primary Care Team
  1. ; (Defaults to DT)
  1. ;
  1. ; Returned: ECXTM -
  1. ; Pointer to team file (#404.51)
  1. ; or, if error or none defined, returns 0
  1. ;
  1. Q:'$G(ECXDFN) 0 ;** Quit if ECXDFN not defined
  1. N ECXTM
  1. S:'$D(ECXDT) ECXDT=DT
  1. I $T(OUTPTTM^SDUTL3)[",SCDATE" D
  1. .S ECXTM=+$$OUTPTTM^SDUTL3(ECXDFN,ECXDT)
  1. I $T(OUTPTTM^SDUTL3)'[",SCDATE" D
  1. .S ECXTM=+$$OUTPTTM^SDUTL3(ECXDFN)
  1. I ECXTM=0 D
  1. .S ECXTM=+$P($G(^DPT(+ECXDFN,"PC")),U,2)
  1. Q ECXTM
  1. ;
  1. OUTPTPR(ECXDFN,ECXDT) ;* Return PC Provider from PCMM files or DPT
  1. ; Variables -
  1. ; ECXDFN - IEN from Patient file (Required)
  1. ; ECXDT - Relevant Date for Primary Care Provider
  1. ; (Defaults to DT)
  1. ;
  1. ; Returned: ECXPR -
  1. ; Pointer to file #200
  1. ; or, if error or none defined, returns a 0
  1. ;
  1. Q:'$G(ECXDFN) 0 ;** Quit if ECXDFN not defined
  1. N ECXPR
  1. S:'$D(ECXDT) ECXDT=DT
  1. I $T(OUTPTPR^SDUTL3)[",SCDATE" D
  1. .S ECXPR=+$$OUTPTPR^SDUTL3(ECXDFN,ECXDT)
  1. I $T(OUTPTPR^SDUTL3)'[",SCDATE" D
  1. .S ECXPR=+$$OUTPTPR^SDUTL3(ECXDFN)
  1. I ECXPR=0 D
  1. .S ECXPR=+$G(^DPT(+ECXDFN,"PC"))
  1. Q ECXPR
  1. ;
  1. PAT(ECXDFN,ECXDATE,ECXDATA,ECXPAT) ;Return basic patient data for extract
  1. ; Will not return data associated with test patients (SSN begin w 00000)
  1. ; Variables -
  1. ; Input ECXDFN - Patient internal entry number, DFN file#2; required
  1. ; ECXDATE- Date used to get specific data from GETSTAT^DGMSTAPI
  1. ; for MST. If no date, defaults to today's date,
  1. ; standard FM format, optional
  1. ; ECXDATA- Code indicating which data to return, optional.
  1. ; If code not specified then returns all. Codes are:
  1. ; 1 - DEM^VADPT (demographic data)
  1. ; 2 - ADD^VADPT (current address)
  1. ; 3 - ELIG^VADPT (eligibility & enrollment location)
  1. ; 4 - OPD^VADPT (other patient data)
  1. ; 5 - SVC^VADPT & GETSTAT^DGMSTAPI (service & MST inf)
  1. ; ECXPAT(- Passed by reference; required
  1. ;
  1. ; Output:
  1. ; ECXPAT 0 error or test patient no data in ECXPAT array
  1. ; 1 data returned in ECXPAT array
  1. ; ECXPAT( Local array with patient data.
  1. ;
  1. N SSN,I,ECXCOD,ECXDAT,DFN,VAPA,VADM,VAEL,VAPD,VASV,STR,ECXAR,DIC,DIQ,RCNUM,RCVAL,COLMETH
  1. N DA,DR,PELG,MELIG,ZIP,MPI,PTNAME ;187 Added PTNAME
  1. I ECXDFN="" Q 0
  1. S PTNAME=$$GET1^DIQ(2,ECXDFN,.01,"I") ;187
  1. I $E(PTNAME,1,2)="ZZ" Q 0 ;187 - exclude patient whose name started with "ZZ"
  1. S SSN=$$GET1^DIQ(2,ECXDFN,.09,"I"),DFN=ECXDFN,ECXPAT=0
  1. ;I $E(SSN,1,3)="000"!(SSN="") K ECXPAT Q 0 ;154 removed as these checks are done in ECXUTL5 ;test patient
  1. ;test patient extended checks; mtl extract excluded
  1. I $G(ECHEAD)'="MTL" D I $G(ECXPAT)="" Q 0 ;154 modified section for SSN testing
  1. .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
  1. .I '$$SSN^ECXUTL5(SSN) K ECXPAT
  1. S STR="NAME;SSN;DOB;SEX;RACE;RELIGION;STATE;COUNTY;ZIP;SC%;MEANS;ELIG;"
  1. S STR=STR_"EMPLOY;AO STAT;IR STAT;EC STAT;POW STAT;POW LOC;MST STAT;"
  1. S STR=STR_"ENROLL LOC;MPI;VIETNAM;POS;MARITAL;CL STAT;COMBSVCI;COMBSVCL" ;149 COMB SVS IND,LOC
  1. ;initialize return array values
  1. F I=1:1 S ECXDAT=$P(STR,";",I) Q:ECXDAT="" S ECXPAT(ECXDAT)=""
  1. F I=1:1:$L(ECXDATA,";") S ECXDAT=$P(ECXDATA,";",I) I ECXDAT'="" D
  1. . S ECXCOD(ECXDAT)=""
  1. ;
  1. ;- Get ICN if MPI installed
  1. S X="MPIF001" X ^%ZOSF("TEST") I $T D
  1. .;
  1. .;- Get 1st piece (either ICN # or -1 if error)
  1. . S MPI=$$GETICN^MPIF001(DFN) ;184 - Removed "+" to include the check sum
  1. .;
  1. .;- If error, set to null
  1. . S ECXPAT("MPI")=$S(MPI>0:MPI,1:"")
  1. D ;get demographic data
  1. . I ECXDATA'="",'$D(ECXCOD(1)) Q
  1. . D DEM^VADPT
  1. . S ECXPAT("NAME")=$E($P(VADM(1),",")_" ",1,4)
  1. . S ECXPAT("SSN")=$P(VADM(2),U),ECXPAT("MARITAL")=$P(VADM(10),U)
  1. . S ECXPAT("DOB")=$$ECXDOB^ECXUTL($P(VADM(3),U))
  1. . S ECXPAT("SEX")=$P(VADM(5),U),ECXPAT("RELIGION")=$P(VADM(9),U)
  1. . S ECXPAT("SIGI")=$P(VADM(14,5),U,2) ;184 - Add SIGI Code
  1. . S DIC=10,DR=2,DA=+VADM(8),DIQ="ECXAR",DIQ(0)="I" D EN^DIQ1
  1. . S ECXPAT("RACE")=$G(ECXAR(10,DA,DR,"I")),ECXPAT=1
  1. . ;add new race and ethnicity fields for FY2003
  1. . S (ECXPAT("ETHNIC"),ECXPAT("RACE1"))=""
  1. . S X="DGUTL4" X ^%ZOSF("TEST") I $T D
  1. .. S COLMETH=$$PTR2CODE^DGUTL4($G(VADM(11,1,1)),3,4) I COLMETH="S" D
  1. ... S ECXPAT("ETHNIC")=$$PTR2CODE^DGUTL4(+$G(VADM(11,1)),2,4)
  1. .. S (RCVAL,RCNUM)=""
  1. .. 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
  1. ... S RCVAL=$$PTR2CODE^DGUTL4(+$G(VADM(12,RCNUM)),1,4)
  1. ... I RCVAL="C" S ECXPAT("RACE1")=RCVAL Q
  1. ... S ECXPAT("RACE1")=ECXPAT("RACE1")_RCVAL
  1. .I ECXPAT("RACE1")="" S ECXPAT("RACE1")=$$CHECKRC(+VADM(8)) ;144 If RACE1 is null, check value in RACE field
  1. D ;get address information
  1. . I ECXDATA'="",'$D(ECXCOD(2)) Q
  1. . D ADD^VADPT
  1. . S DIC=5,DR=2,DA=+VAPA(5),DIQ="ECXAR",DIQ(0)="I" D EN^DIQ1
  1. . S ECXPAT("STATE")=$G(ECXAR(5,DA,DR,"I"))
  1. . S DIC=5,DA=+VAPA(5),DR=3,DR(5.01)=2,DA(5.01)=+VAPA(7),DIQ="ECXAR"
  1. . S DIQ(0)="I" D EN^DIQ1
  1. . S ECXPAT("COUNTY")=$G(ECXAR(5.01,DA(5.01),2,"I"))
  1. . S ECXPAT("ZIP")=$P(VAPA(11),U,2)
  1. . S ECXPAT("COUNTRY")=$$GET1^DIQ(779.004,+$P($G(VAPA(25)),U),.01)
  1. . S ECXPAT=1
  1. D ;get eligibility information
  1. . I ECXDATA'="",'$D(ECXCOD(3)) Q
  1. . D ELIG^VADPT
  1. . S PELG=$P(VAEL(1),U),MELIG=$S(PELG="":"",1:$$GET1^DIQ(8,PELG,8,"I"))
  1. . S ECXPAT("POS")=$P($G(^DIC(21,+VAEL(2),0)),U,3)
  1. . S ECXPAT("SC STAT")=$S(+VAEL(3):"Y",+VAEL(3)=0:"N",1:"")
  1. . S ECXPAT("SC%")=$P(VAEL(3),U,2)
  1. . S ECXPAT("VET")=$S(VAEL(4):"Y",VAEL(4)=0:"N",1:"")
  1. . S ECXPAT("MEANS")=$P(VAEL(9),U),ECXPAT=1
  1. . S ECXPAT("ELIG")=$$ELIG(MELIG,ECXPAT("SC%"))
  1. . ;get enrollment location
  1. . S DIC=2,DR=27.02,DA=ECXDFN,DIQ="ECXAR",DIQ(0)="I" D EN^DIQ1
  1. . S ECXDAT=$G(ECXAR(2,ECXDFN,DR,"I")) I ECXDAT K ECXAR D
  1. . . S DIC=4,DA=ECXDAT,DR=99,DIQ="ECXAR",DIQ(0)="I" D EN^DIQ1
  1. . . S ECXPAT("ENROLL LOC")=ECXAR(4,ECXDAT,DR,"I")
  1. . ;get Emergency Response Indicator (FEMA)
  1. . S ECXPAT("ERI")=$$GET1^DIQ(2,ECXDFN,.181,"I")
  1. D ;get other patient information
  1. . I ECXDATA'="",'$D(ECXCOD(4)) Q
  1. . D OPD^VADPT
  1. . S ECXPAT("EMPLOY")=$P(VAPD(7),U),ECXPAT=1
  1. D ;get service information
  1. . I ECXDATA'="",'$D(ECXCOD(5)) Q
  1. . D SVC^VADPT
  1. . S ECXPAT("VIETNAM")=$S(VASV(1):"Y",VASV(1)=0:"N",1:"U") ;149
  1. . S ECXPAT("AO STAT")=$S(VASV(2):"Y",VASV(2)=0:"N",1:"U")
  1. . S ECXPAT("IR STAT")=$S(VASV(3):"Y",VASV(3)=0:"N",1:"U")
  1. . I $G(ECXLOGIC)>2017 S ECXPAT("IR STAT")=$S(VASV(3):$P($G(VASV(3,2)),U),VASV(3)=0:"1",1:"U")
  1. . S ECXPAT("EC STAT")=$$GET1^DIQ(2,ECXDFN,.322013,"I")
  1. . S ECXPAT("POW STAT")=$S(VASV(4):"Y",VASV(4)=0:"N",1:"U")
  1. . S ECXPAT("POW LOC")=$P(VASV(4,3),U),ECXPAT=1
  1. . S ECXPAT("PHI")=$S(VASV(9)=1:"Y",VASV(9)=0:"N",1:"")
  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
  1. . ;- Agent Orange Location (K=Korean DMZ,V=Vietnam)
  1. . S ECXPAT("AOL")=$P($G(VASV(2,5)),U)
  1. . S ECXPAT("COMBSVCI")=$S(VASV(5):"Y",VASV(5)=0:"N",1:"") ;149 COMBAT SVC IND
  1. . S ECXPAT("COMBSVCL")=$$GET1^DIQ(22,$P($G(VASV(5,3)),"^"),1) ;149 COMBAT SVC LOC USE ABBR
  1. . ;get patient OEF/OIF status and date of return
  1. . D OEFDATA^ECXUTL4
  1. . ;
  1. . ;get patient current MST status
  1. . I ECXDATE'="",ECXDATE'["." S ECXDATE=ECXDATE+.9
  1. . S X="DGMSTAPI" X ^%ZOSF("TEST") I $T D
  1. . . S ECXDAT=$$GETSTAT^DGMSTAPI(DFN,ECXDATE)
  1. . . S ECXPAT("MST STAT")=$S(+ECXDAT>0:$P(ECXDAT,U,2),1:"")
  1. I 'ECXPAT K ECXPAT Q 0
  1. Q 1
  1. ;
  1. ELIG(ECXELIG,ECXSVCP) ;Converts veteran eligibility code to NPCD code
  1. ; Variables -
  1. ; Input ECXELIG - Pointer to MAS ELIGIBILITY CODE file #8.1
  1. ; ECXSVCP - Number value rep. service connected percentage.
  1. ;
  1. ; Output:
  1. ; ECXNCPD NPCD Eligibility Code
  1. ;
  1. N TEXT,IEN,SCPER,FND,NPCD,I,ECXBG,ECXEN,ECXNPCD
  1. I ECXELIG="" Q ""
  1. F I=1:1 S TEXT=$P($T(ELGTXT+I),";",3,999) Q:TEXT="END" D I $D(NPCD) Q
  1. . S IEN=$P(TEXT,";"),SCPER=$P(TEXT,";",2)
  1. . I ECXELIG=IEN D
  1. . . I SCPER="" S NPCD=$P(TEXT,";",3) Q
  1. . . S ECXBG=$S($E(SCPER)="<":0,$E(SCPER)=">":$P(SCPER,">",2)+1,SCPER["-":+SCPER,1:"")
  1. . . S ECXEN=$S($E(SCPER)="<":$P(SCPER,"<",2),$E(SCPER)=">":100,SCPER["-":$P(SCPER,"-",2),1:"")
  1. . . I ECXSVCP'<ECXBG,ECXSVCP'>ECXEN S NPCD=$P(TEXT,";",3)
  1. S ECXNPCD=$G(NPCD)
  1. Q ECXNPCD
  1. ELGTXT ;Eligibility codes
  1. ;;1;>49;10;SC 50-100%
  1. ;;2;;20;Aid & Attendance
  1. ;;15;;21;Housebound
  1. ;;16;;22;Mexican Border War
  1. ;;17;;23;WWI
  1. ;;18;;24;POW
  1. ;;3;40-49;30;SC 40-49%
  1. ;;3;30-39;31;SC 30-39%
  1. ;;3;20-29;32;SC 20-29%
  1. ;;3;10-19;33;SC 10-19%
  1. ;;3;<10;34;SC less than 10%
  1. ;;4;;40;NSC - VA Pension
  1. ;;5;;50;NSC
  1. ;;21;;60;Catastrophic Disability
  1. ;;12;;101;CHAMPVA
  1. ;;13;;102;Collateral of Veteran
  1. ;;14;;103;Employee
  1. ;;6;;104;Other Federal Agency
  1. ;;7;;105;Allied Veteran
  1. ;;8;;106;Humanitarian Emergency
  1. ;;9;;107;Sharing Agreement
  1. ;;10;;108;Reimbursable Insurance
  1. ;;19;;109;TRICARE/CHAMPUS
  1. ;;22;;25;Purple Heart Recipient
  1. ;;END
  1. ;
  1. 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
  1. ;plus up to 5 modifier codes, 2 characters each.
  1. ; Variables -
  1. ; Input ECXCPT - Pointer value to the CPT file (#81)
  1. ; ECXMOD - A string with pointer values to the CPT
  1. ; MODIFIER file (#81.3) separated by ";"
  1. ; ECXQUA - Number of time this procedure performed
  1. ;
  1. ; Output:
  1. ; CPTMOD - String of up to 17 characters, 5 character CPT
  1. ; code 2 character qty plus up to 5 2-character
  1. ; code modifiers.
  1. ;
  1. N CPT,MOD,I,CPTMOD
  1. S ECXQUA=$G(ECXQUA,"01"),ECXMOD=$G(ECXMOD)
  1. S:$L(ECXQUA)'=2 ECXQUA="0"_ECXQUA
  1. S CPT=$$CPT^ICPTCOD(ECXCPT,"") I +CPT=-1 Q ""
  1. S CPT=$P(CPT,U,2)_ECXQUA
  1. F I=1:1:99 I $P(ECXMOD,";",I)'="" D
  1. . S MOD=$$MOD^ICPTMOD($P(ECXMOD,";",I),"I","")
  1. . I +MOD>0,$P(MOD,U,2)'="99" S CPT=CPT_$P(MOD,U,2)
  1. S CPTMOD=$TR($E(CPT,1,17)," ")
  1. Q CPTMOD
  1. ;
  1. CPT3Q6M(ECXCPT,ECXMOD,ECXQUA) ;
  1. ;
  1. ; This API was created for patch 170 (FY19) to handle 3-digit quantities
  1. ; and up to 6 modifiers.
  1. ;
  1. ; Return string is composed of a 5-character CPT code, 3-character quantity
  1. ; and up to 6 2-character modifier codes.
  1. ;
  1. ; Variables -
  1. ; Input ECXCPT - Pointer value to the CPT file (#81)
  1. ; ECXMOD - A string with pointer values to the CPT
  1. ; MODIFIER file (#81.3) separated by ";"
  1. ; ECXQUA - Number of times this procedure was performed
  1. ;
  1. ; Output:
  1. ; CPTMOD - String of up to 20 characters - a 5-character CPT
  1. ; code, 3-character quantity, and up to 6 2-character
  1. ; code modifiers.
  1. ;
  1. N CPT,MOD,I,CPTMOD,LEN
  1. S ECXQUA=$G(ECXQUA,"001"),ECXMOD=$G(ECXMOD)
  1. F LEN=1,2 I $L(ECXQUA)=LEN S ECXQUA="0"_ECXQUA
  1. S CPT=$$CPT^ICPTCOD(ECXCPT,"") I +CPT=-1 Q ""
  1. S CPT=$P(CPT,U,2)_ECXQUA
  1. F I=1:1:99 I $P(ECXMOD,";",I)'="" D
  1. . S MOD=$$MOD^ICPTMOD($P(ECXMOD,";",I),"I","")
  1. . I +MOD>0,$P(MOD,U,2)'="99" S CPT=CPT_$P(MOD,U,2)
  1. S CPTMOD=$TR($E(CPT,1,20)," ")
  1. Q CPTMOD
  1. CPTOUT(ECXCPT) ;output transform for CPT code plus modifiers
  1. ;input ECXCPT - character string of CPT code plus modifiers (required)
  1. ;
  1. N J,CPTX,MOD,MODS,MODX,CPTMOD
  1. Q:$G(ECXCPT)="" ""
  1. S (CPTMOD,MODX)=""
  1. S CPTX="("_+$E(ECXCPT,6,7)_") "_$E(ECXCPT,1,5),MODS=$E(ECXCPT,8,17)
  1. F J=1:2:9 S MOD=$E(MODS,J,J+1) Q:MOD="" D
  1. .I J>1 S MODX=MODX_", "_MOD Q
  1. .S MODX=MODX_"-"_MOD
  1. S:$L(CPTX)>3 CPTMOD=CPTMOD_CPTX_MODX
  1. Q CPTMOD
  1. ;
  1. 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. N NAME,DIC,X,Y,PTFVAL
  1. S NAME=$$PTR2TEXT^DGUTL4(RACEIEN)
  1. S PTFVAL=""
  1. 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"
  1. I NAME="AMERICAN INDIAN/ALASKA NATIVE"!(NAME="AMERICAN INDIAN/ALASKAN")!(NAME="AMERICAN INDIANT OR ALASKA NATIVE") S X="AMERICAN INDIAN OR ALASKA NATIVE"
  1. 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"
  1. I NAME="BLACK,NOT OF HISPANIC ORIGIN"!(NAME="HISPANIC BLACK")!(NAME="HISPANIC, BLACK")!(NAME="HISPANIC,BLACK") S X="BLACK OR AFRICAN AMERICAN"
  1. 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"
  1. I NAME="CAUCASIAN"!(NAME="CAUCASIAN, NOT OF HISPANIC ORIGIN")!(NAME="HISPANIC WHITE")!(NAME="HISPANIC, WHITE")!(NAME="HISPANIC,WHITE") S X="WHITE"
  1. I NAME="PACIFIC ISLANDER" S X="NATIVE HAWAIIAN OR OTHER PACIFIC ISLANDER"
  1. S DIC(0)="MQ",DIC=10 D ^DIC ;Find standard race in RACE file
  1. I Y S PTFVAL=$$PTR2CODE^DGUTL4(+Y,1,4) ;If found, get PTF value to return
  1. Q PTFVAL