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