source: FOIAVistA/tag/r/ZZREGIONAL-A1C-A5C-CRHD-RGED-RGUT-RGWB-RG/RGRSPARS.m@ 1789

RGRSPARS ;ALB/RJS-REGISTRATION MESSAGE PARSER FOR CIRN ;3/8/96
 ;;1.0; CLINICAL INFO RESOURCE NETWORK ;;30 Apr 99
EN(ARRAY) ;
 ;This procedure call returns an array of patient information in the 
 ;corresponding PATIENT file (#2) field numbers as well as Patient
 ;sensitivity.
 ;
 ;Input: Required Variable
 ;
 ; ARRAY - Supplied array variable (Pass by reference)
 ;
 ;Output:
 ;
 ; ARRAY - Array of patient information gathered from HL7 segments
 ;
 N RGRSPID,RGRSZEL,RGRSZPD,RGRSZSP,RGC,RGRSPD1,RGRSZEM,RGRSZCT,RGRSZFF
 N STATE,STATEIEN,SUBCOMP,STREETS,INSTITU,CNTYCODE,ADDRESS,RGRSOBX
 N RGRSMSH
 S RGC=$E(HL("ECH")),SUBCOMP=$E(HL("ECH"),2)
 S RGRSMSH=$$SEG1^RGRSUTIL("MSH",1,"MSH")
 S RGRSPID=$$SEG1^RGRSUTIL("PID",1,"PID")
 S RGRSPD1=$$SEG1^RGRSUTIL("PD1",1,"PD1")
 S RGRSZEL=$$SEG1^RGRSUTIL("ZEL",1,"ZEL")
 S RGRSZPD=$$SEG1^RGRSUTIL("ZPD",1,"ZPD")
 S RGRSZSP=$$SEG1^RGRSUTIL("ZSP",1,"ZSP")
 S RGRSZEM=$$SEG1^RGRSUTIL("ZEM",1,"ZEM")
 S RGRSZCT=$$SEG1^RGRSUTIL("ZCT",1,"ZCT")
 S RGRSZFF=$$SEG1^RGRSUTIL("ZFF",1,"ZFF")
 S RGRSOBX=$$SEG1^RGRSUTIL("OBX",1,"OBX")
 S @ARRAY@(.01)=$$FREE($$FMNAME^HLFNC($P(RGRSPID,HL("FS"),6),HL("ECH"))) ;NAME
 S @ARRAY@(.02)=$$SEX($P(RGRSPID,HL("FS"),9)) ;SEX
 S @ARRAY@(.03)=$$FREE($$FMDATE^HLFNC($P(RGRSPID,HL("FS"),8))) ;DOB
 S @ARRAY@(.05)=$$MARITAL($P(RGRSPID,HL("FS"),17)) ;MARITAL STATUS
 S @ARRAY@(.08)=$$RELIG($P(RGRSPID,HL("FS"),18)) ;RELIGIOUS PREFERENCE
 S @ARRAY@(.09)=$$FREE($P(RGRSPID,HL("FS"),20)) ;SOCIAL SECURITY #
 S ADDRESS=$$FREE($P(RGRSPID,HL("FS"),12)) ;ADDRESS FIELDS
 S @ARRAY@(.111)=$$FREE($P(ADDRESS,RGC,1)) ;STREET ADDRESS [1]
 S @ARRAY@(.112)=$$FREE($P(ADDRESS,RGC,2)) ;STREET ADDRESS [2]
 S @ARRAY@(.113)=$$FREE($P(ADDRESS,RGC,8)) ;STREET ADDRESS [3]
 S @ARRAY@(.114)=$$FREE($P($P(RGRSPID,HL("FS"),12),RGC,3)) ;CITY
 S @ARRAY@(.115)=$$STATE($P($P(RGRSPID,HL("FS"),12),RGC,4)) ;STATE
 S @ARRAY@(.1112)=$$FREE($P($P(RGRSPID,HL("FS"),12),RGC,5)) ;ZIP+4
 S CNTYCODE=$P(RGRSPID,HL("FS"),13) ;COUNTY CODE
 S @ARRAY@(.117)=$$COUNTY(@ARRAY@(.115),CNTYCODE)
 S @ARRAY@(.131)=$$FREE($P(RGRSPID,HL("FS"),14)) ;PHONE NUMBER-HOME
 S @ARRAY@(.132)=$$FREE($P(RGRSPID,HL("FS"),15)) ;PHONE NUMBER-WORK
 S @ARRAY@(.211)=$$FREE($P(RGRSZCT,HL("FS"),4)) ;K-NAME
 S @ARRAY@(.219)=$$FREE($P(RGRSZCT,HL("FS"),7)) ;K-PHONE NUMBER
 S @ARRAY@(.2403)=$$FREE($P(RGRSPID,HL("FS"),7)) ;MOTHERS MAIDEN NAME
 S @ARRAY@(.301)=$$YESNO($P(RGRSZSP,HL("FS"),3)) ;SERVICE CONNECTED
 S @ARRAY@(.302)=$$FREE($P(RGRSZSP,HL("FS"),4)) ;SERVICE CONNECTED PERCENTAGE
 S @ARRAY@(.31115)=$$EMP($P(RGRSZEM,HL("FS"),4)) ;EMPLOYMENT STATUS
 S @ARRAY@(.323)=$$POS($P(RGRSZSP,HL("FS"),5)) ;PERIOD OF SERVICE
 S @ARRAY@(.351)=$$FREE($$FMDATE^HLFNC($P(RGRSZPD,HL("FS"),10))) ;DATE OF DEATH
 S @ARRAY@(.361)=$$ELIG($P(RGRSZEL,HL("FS"),3)) ;PRIMARY ELIGIBILITY CODE
 S @ARRAY@(.3612)=$$FREE($$FMDATE^HLFNC($P(RGRSZEL,HL("FS"),12))) ;DT VER
 S @ARRAY@(.3615)=$$FREE($P(RGRSZEL,HL("FS"),14)) ;VERIFICATION METHOD
 S @ARRAY@(391)=$$TYPE($P(RGRSZEL,HL("FS"),10)) ;PATIENT TYPE
 S @ARRAY@(1901)=$$VETERAN($P(RGRSZEL,HL("FS"),9)) ;VETERAN (Y/N)
 S @ARRAY@(991.01)=$$FREE($P($P(RGRSPID,HL("FS"),3),"V",1)) ;INTEG CONTROL #
 S @ARRAY@(991.02)=$$FREE($P($P(RGRSPID,HL("FS"),3),"V",2)) ;CHECKSUM
 S @ARRAY@(991.03)=$$FREE($P($P(RGRSPD1,HL("FS"),4),RGC,1)) ;VCCI
 S @ARRAY@("SENDING SITE")=$$FREE($P(RGRSMSH,HL("FS"),4)) ;SENDING SITE
 S @ARRAY@("SITENUM")=$$FREE($P($P(RGRSPD1,HL("FS"),4),RGC,3)) ;VCCI SITENUM
 S @ARRAY@("DFN")=$$FREE($P($P(RGRSPID,HL("FS"),4),RGC,1)) ;DFN
 S @ARRAY@("FLD")=$P(RGRSZFF,HL("FS"),3) ;FIELD(S) EDITED
 I $$FREE($P($P(RGRSOBX,HL("FS"),4),RGC,2))="SECURITY LEVEL" DO
 . S @ARRAY@("SENSITIVITY")=$$SENSTIVE($P(RGRSOBX,HL("FS"),6),RGC) ;SENSTIVITY
 . S @ARRAY@("SENSITIVITY USER")=$$FREE($P($P(RGRSOBX,HL("FS"),17),RGC,2))_","_$$FREE($P($P(RGRSOBX,HL("FS"),17),RGC,3)) ;REMOTE PERSON WHO MADE PT. SENSITIVE
 . S @ARRAY@("SENSITIVITY DATE")=$$FREE($$FMDATE^HLFNC($P(RGRSOBX,HL("FS"),15))) ;DATE/TIME PERSON MADE PT. SENSITIVE AT REMOTE SITE
 D NOW^%DTC S @ARRAY@(.097)=X
 K %H,%I,X,%
 Q
 ;
VETERAN(HLCODE) ;
 Q:$$FREE(HLCODE)="" ""
 Q:$$FREE(HLCODE)="""@""" """@"""
 Q:HLCODE=1 "YES"
 Q:HLCODE=0 "NO"
 Q HLCODE_"^1"
 ;
STATE(STATE) ;
 N RETURN,STATEIEN
 Q:$$FREE(STATE)="" ""
 Q:$$FREE(STATE)="""@""" """@"""
 S STATEIEN=$O(^DIC(5,"C",STATE,0))
 I $G(STATEIEN)="" Q STATE_"^1"
 S RETURN=$P(^DIC(5,STATEIEN,0),"^",1)
 Q:$G(RETURN)'="" RETURN
 Q STATE_"^1"
 ;
COUNTY(STATE,CNTYCODE) ;
 ;This function entry point is used to obtain the county name
 ;
 ;Input: Required Variables
 ;
 ; STATE - State name
 ; CNTYCODE - County code
 ;
 ;Output:
 ; County name   - If known
 ;    "@"        - If missing required input
 ; County Code^1 - If county code was unknown
 ;
 N STATEIEN,COUNTIEN,CNTYNAME
 Q:$G(STATE)=""!($G(STATE)=HL("Q"))!($G(CNTYCODE)="") ""
 Q:$G(CNTYCODE)=HL("Q") """@"""
 S STATEIEN=$O(^DIC(5,"B",STATE,0))
 Q:$G(STATEIEN)'>0 CNTYCODE_"^1"
 S COUNTIEN=$O(^DIC(5,STATEIEN,1,"C",CNTYCODE,0))
 Q:$G(COUNTIEN)'>0 CNTYCODE_"^1"
 S CNTYNAME=$P(^DIC(5,STATEIEN,1,COUNTIEN,0),"^",1)
 Q:$L(CNTYNAME)'>0 CNTYCODE_"^1"
 Q $G(CNTYNAME)
 ;
KILL ;
 K @ARRAY
 Q
 ;
FREE(DATA) ;
 Q:$G(DATA)="" ""
 Q:DATA=HL("Q") """@"""
 Q $G(DATA)
SEX(DATA) ;
 Q:$$FREE(DATA)="" ""
 Q:$$FREE(DATA)="""@""" """@"""
 I DATA="M" Q "MALE"
 I DATA="F" Q "FEMALE"
 Q "^<UNRESOLVED>"
 ;
MARITAL(DATA) ;
 Q:$$FREE(DATA)="" ""
 Q:$$FREE(DATA)="""@""" """@"""
 Q:DATA="A" "SEPARATED"
 Q:DATA="D" "DIVORCED"
 Q:DATA="M" "MARRIED"
 Q:DATA="S" "NEVER MARRIED"
 Q:DATA="W" "WIDOW/WIDOWER"
 Q:DATA="U" "UNKNOWN"
 Q DATA_"^1"
 ;
SENSTIVE(DATA,SUBCOMP) ;
 Q:$G(DATA)="" 0
 Q:$P(DATA,SUBCOMP,1)=1 1
 Q 0
 ;
YESNO(DATA) ;
 Q:$$FREE(DATA)="" ""
 Q:$$FREE(DATA)="""@""" """@"""
 I DATA="1" Q "YES"
 I DATA="0" Q "NO"
 Q "^<UNRESOLVED>"
RELIG(DATA) ;
 N IEN,RELIG
 Q:$$FREE(DATA)="" ""
 Q:$$FREE(DATA)="""@""" """@"""
 S IEN=$O(^DIC(13,"C",DATA,0))
 I $G(IEN)="" Q DATA_"^1"
 S RELIG=$P($G(^DIC(13,IEN,0)),"^",1)
 I $G(RELIG)="" Q DATA_"^1"
 Q $G(RELIG)
POS(DATA) ;
 N IEN,POS
 Q:$$FREE(DATA)="" ""
 Q:$$FREE(DATA)="""@""" """@"""
 S IEN=$O(^DIC(21,"D",DATA,0))
 I $G(IEN)="" Q DATA_"^1"
 S POS=$P($G(^DIC(21,IEN,0)),"^",1)
 I $G(POS)="" Q DATA_"^1"
 Q $G(POS)
ELIG(DATA)      ;
 N IEN,ELIGPTR,ELIG
 Q:$$FREE(DATA)="" ""
 Q:$$FREE(DATA)="""@""" """@"""
 S ELIGPTR=$O(^DIC(8,"D",DATA,0))
 I $G(ELIGPTR)'>0 Q DATA_"^1"
 S ELIG=$P($G(^DIC(8,ELIGPTR,0)),"^",1)
 I $G(ELIG)="" Q DATA_"^1"
 Q $G(ELIG)
TYPE(DATA) ;
 N IEN,TYPE
 Q:$$FREE(DATA)="" ""
 Q:$$FREE(DATA)="""@""" """@"""
 S IEN=$O(^DG(391,"B",DATA,0))
 I $G(IEN)="" Q DATA_"^1"
 S TYPE=$P($G(^DG(391,IEN,0)),"^",1)
 I $G(TYPE)="" Q DATA_"^1"
 Q $G(TYPE)
EMP(DATA) ;
 N IEN,EMP
 Q:$$FREE(DATA)="" ""
 Q:$$FREE(DATA)="""@""" """@"""
 Q:DATA=1 "EMPLOYED FULL TIME"
 Q:DATA=2 "EMPLOYED PART TIME"
 Q:DATA=3 "NOT EMPLOYED"
 Q:DATA=4 "SELF EMPLOYED"
 Q:DATA=5 "RETIRED"
 Q:DATA=6 "ACTIVE MILITARY DUTY"
 Q:DATA=9 "UNKNOWN"
 Q DATA_"^1"