AGMPIHL1 ;IHS/SD/TPF - Patient Registration MPI HLO Interface ext ALL HLO MESSAGES
;;7.2;IHS PATIENT REGISTRATION;**1**;JAN 07, 2011
;CALLED FROM AGMPIHLO
Q
; Create PID segment
PID(DFN) ;EP
N HRCN,FLD,LP,VAL,ASU,COMP,SUBCOMP
I '$G(DFN) S ERR="DFN UNDEF IN PID^AGMPIHL1" Q
I $G(^DPT(DFN,0))="" S ERR="DPT 0 NODE FOR "_DFN_" NOT DEFINED IN PID^AGMPIHL1" Q
I $P($G(^DPT(DFN,0)),U)="" S ERR="DPT 0 NODE P^1 "_DFN_"NOT POPULATED IN PID^AGMPIHL1" Q
;PID(1)="PID^1^V^253032882P~~~USSSA&&0363~SS~VA FACILITY ID&14752&L|
;5571~~~USVHA&&0363~PI~VA FACILITY ID&14752&L
;^^GEGNUN~DELORES~M~~~~L^BUWSTRYNG~HARRY~M~~~~M^19820328^F^^^
;11419 3RD ST~~MORRIS~MN~~~P~|~~MINNEAPOLIS~MN~~~N^^(555)555-1732^^^^^^253032882P^^"
;PID(2)="^^MINNEAPOLIS MN^^^^^^^^"
;
;PID(1)="PID^1^V^V~~~USVHA&&0363~NI~VA FACILITY ID&14752&L|253032882P~~~USSSA&&03
;63~SS~VA FACILITY ID&14752&L|5571~~~USVHA&&0363~PI~VA FACILITY ID&14752&L^^GEGNU
;N~DELORES~M~~~~L^BUWSTRYNG~HARRY~M~~~~M^19820328^F^^^11419 3RD ST~~MORRIS~MN~~~P
;~|~~MINNEAPOL"
;PID(2)="IS~MN~~~N^^(555)555-1732^^^^^^253032882P^^^^MINNEAPOLIS MN^^^^^^^^
S FACNAME=$$GET1^DIQ(9999999.06,DUZ(2)_",",.01,"E")
K PID,ERR
D BLDPID^AGMPIPID(DFN,1,"ALL",.PID,.HL1,.ERR)
S PID(1)=PID(1)_$G(PID(2))
D MYSET(.ARY,"PID",0)
D MYSET(.ARY,1,1,1,1,1) ;ALWAYS 1
D MYSET(.ARY,$P(PID(1),HL1("FS"),3),2,1,1,1)
D MYSET(.ARY,$P($P(PID(1),HL1("FS"),4),"~"),3,1,1,1)
D MYSET(.ARY,"USIHS",3,1,4,1)
D MYSET(.ARY,"0363",3,1,4,3) ;THIS REFERS TO A TABLE BUT I CAN'T FIND IN VA DOC
D MYSET(.ARY,"NI",3,1,5,1)
D MYSET(.ARY,"IHS FACILITY ID - "_FACNAME,3,1,6,1)
D MYSET(.ARY,$P($$SITE^VASITE,"^",3),3,1,6,2)
D MYSET(.ARY,"L",3,1,6,3)
D MYSET(.ARY,$P($P(PID(1),"|",2),"~"),3,2,1,1)
D MYSET(.ARY,"USSSA",3,2,4,1)
D MYSET(.ARY,"0363",3,2,4,3)
D MYSET(.ARY,"SS",3,2,5,1)
D MYSET(.ARY,"IHS FACILITY ID - "_FACNAME,3,2,6,1)
D MYSET(.ARY,$P($$SITE^VASITE,"^",3),3,2,6,2)
D MYSET(.ARY,"L",3,2,6,3)
D MYSET(.ARY,DFN,3,3,1,1)
D MYSET(.ARY,"USIHS",3,3,4,1)
D MYSET(.ARY,"0363",3,3,4,3)
D MYSET(.ARY,"PI",3,3,5,1)
D MYSET(.ARY,"IHS FACILITY ID - "_FACNAME,3,3,6,1)
D MYSET(.ARY,$P($$SITE^VASITE,"^",3),3,3,6,2)
D MYSET(.ARY,"L",3,3,6,3)
D MYSET(.ARY,$P(PID(1),HL1("FS"),3),3,4,1,1)
D MYSET(.ARY,"USIHS",3,4,4,1)
D MYSET(.ARY,"0363",3,4,4,3)
D MYSET(.ARY,"NI",3,4,5,1)
D MYSET(.ARY,"IHS FACILITY ID - "_FACNAME,3,4,6,1)
D MYSET(.ARY,$P($$SITE^VASITE,"^",3),3,4,6,2)
D MYSET(.ARY,"L",3,4,6,3)
D MYSET(.ARY,"200910205571-0700",3,4,8,1)
D MYSET(.ARY,$P($P(PID(1),HL1("FS"),6),"~"),5,1,1,1) ;LAST NAME
D MYSET(.ARY,$P($P(PID(1),HL1("FS"),6),"~",2),5,1,2,1) ;FIRST NAME
D MYSET(.ARY,$P($P(PID(1),HL1("FS"),6),"~",3),5,1,3,1) ;MIDDLE NAME
D MYSET(.ARY,$P($P(PID(1),HL1("FS"),6),"~",4),5,1,4,1)
D MYSET(.ARY,$P($P(PID(1),HL1("FS"),6),"~",5),5,1,5,1)
D MYSET(.ARY,$P($P(PID(1),HL1("FS"),6),"~",6),5,1,6,1)
D MYSET(.ARY,$P($P(PID(1),HL1("FS"),6),"~",7),5,1,7,1)
D MYSET(.ARY,$P($P(PID(1),HL1("FS"),7),"~"),6,1,1,1)
D MYSET(.ARY,$P($P(PID(1),HL1("FS"),7),"~",2),6,1,2,1)
D MYSET(.ARY,$P($P(PID(1),HL1("FS"),7),"~",3),6,1,3,1)
D MYSET(.ARY,$P($P(PID(1),HL1("FS"),7),"~",4),6,1,4,1)
D MYSET(.ARY,$P($P(PID(1),HL1("FS"),7),"~",5),6,1,5,1)
D MYSET(.ARY,$P($P(PID(1),HL1("FS"),7),"~",6),6,1,6,1)
D MYSET(.ARY,$P($P(PID(1),HL1("FS"),7),"~",7),6,1,7,1)
D MYSET(.ARY,$P(PID(1),HL1("FS"),8),7,1,1,1) ;DOB
D MYSET(.ARY,$P(PID(1),HL1("FS"),9),8,1,1,1) ;SEX
D MYSET(.ARY,$P(PID(1),HL1("FS"),10),9,1,1,1)
D MYSET(.ARY,$P(PID(1),HL1("FS"),11),10,1,1,1) ;RACE
D MYSET(.ARY,$P($P(PID(1),HL1("FS"),12),"~"),11,1,1,1) ;FIRST LINE
D MYSET(.ARY,$P($P(PID(1),HL1("FS"),12),"~",2),11,1,2,1) ;SEC LINE
D MYSET(.ARY,$P($P(PID(1),HL1("FS"),12),"~",3),11,1,3,1) ;CITY
D MYSET(.ARY,$P($P(PID(1),HL1("FS"),12),"~",4),11,1,4,1) ;STATE
D MYSET(.ARY,$P($P(PID(1),HL1("FS"),12),"~",5),11,1,5,1) ;ZIP
D MYSET(.ARY,$P($P(PID(1),HL1("FS"),12),"~",6),11,1,6,1)
D MYSET(.ARY,$P($P(PID(1),HL1("FS"),12),"~",7),11,1,7,1) ;ADDRESS TYPE P=PERMANENT
D MYSET(.ARY,$P($P($P(PID(1),HL1("FS"),12),"~",8),"|"),11,1,8,1) ;THIRD LINE
;G CONTPID
D MYSET(.ARY,$P($P(PID(1),"|",4),"~"),11,2,3,1)
D MYSET(.ARY,$P($P(PID(1),"|",4),"~",2),11,2,2,1)
D MYSET(.ARY,$P($P(PID(1),"|",4),"~",3),11,2,3,1)
D MYSET(.ARY,$P($P(PID(1),"|",4),"~",4),11,2,4,1)
D MYSET(.ARY,$P($P(PID(1),"|",4),"~",5),11,2,5,1)
D MYSET(.ARY,$P($P(PID(1),"|",4),"~",6),11,2,6,1)
D MYSET(.ARY,"N",11,2,7,1) ;address type
;
;DO ALIASES
D SALIAS(DFN)
;PID-13 PHONES AND EMAIL ;SET(SEG,VALUE,FIELD,COMP,SUBCOMP,REP)
;ADDED THESE FOR PAHSE 2
D MYSET(.ARY,$P($P(PID(1),HL1("FS"),14),"~"),13,1,1,1) ;PHONE #
D MYSET(.ARY,$P($P(PID(1),HL1("FS"),14),"~",2),13,1,2,1) ;PRIMARY
D MYSET(.ARY,$P($P(PID(1),HL1("FS"),14),"~",3),13,1,3,1) ;PHONE
D MYSET(.ARY,$P($P(PID(1),HL1("FS"),15),"~"),13,2,1,1) ;PHONE #
D MYSET(.ARY,$P($P(PID(1),HL1("FS"),15),"~",2),13,2,2,1) ;WORK
D MYSET(.ARY,$P($P(PID(1),HL1("FS"),15),"~",3),13,2,3,1) ;PHONE
D MYSET(.ARY,$P($P(PID(1),HL1("FS"),25),"~"),13,3,1,1) ;PHONE #
D MYSET(.ARY,$P($P(PID(1),HL1("FS"),25),"~",2),13,3,2,1) ;OTHER
D MYSET(.ARY,$P($P(PID(1),HL1("FS"),25),"~",3),13,3,3,1) ;CELL
D MYSET(.ARY,$P($P(PID(1),HL1("FS"),26),"~"),13,4,1,1) ;EMAIL
D MYSET(.ARY,$P($P(PID(1),HL1("FS"),26),"~",2),13,4,2,1) ;NET
D MYSET(.ARY,$P($P(PID(1),HL1("FS"),26),"~",3),13,4,3,1) ;INTERNET
D MYSET(.ARY,$P(PID(1),HL1("FS"),17),16,1,1,1) ;MARITAL STATUS
D MYSET(.ARY,$P(PID(1),HL1("FS"),18),17,1,1,1) ;RELIGION
D MYSET(.ARY,$P(PID(1),HL1("FS"),23),22,1,1,1) ;ETHNICITY
D MYSET(.ARY,$P(PID(1),HL1("FS"),27),27,1,1,1) ;VETERAN STATUS
D MYSET(.ARY,$P(PID(1),HL1("FS"),29),29,1,1,1) ;DATE OF DEATH
;
CONTPID ;EP -
S X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
I $D(ERR) D NOTIF^AGMPIHLO(DFN,ERR)
Q
;
VTQ(DFN) ;EP - CREATE VTQ DIRECT CONNECT EXACT MATCH QUERY
;"VTQ^100127^T^EXACT_MATCH_QUERY^ICN^@00108.1~EQ~GOLDTEST~AND|@00122~EQ
;~153050678P~AND|@00108.2~EQ~ADD~AND|@00110~EQ~19780506~AND|@00111~EQ~F~AND|@0010
;8.3~EQ~NOSSN"
Q:'$G(DFN)
N VTQ,SEX,DOB,NAME,FIRSTNAM,LASTNAM,MIDNAME,SSN
;
S SEX=$P(^DPT(DFN,0),U,2)
S DOB=$P(^DPT(DFN,0),U,3)
S DOB=$$HLDATE^HLFNC(DOB,"TS")
S SSN=$P(^DPT(DFN,0),U,9)
S NAME=$P(^DPT(DFN,0),U)
S NAME=$$HLNAME^XLFNAME(NAME,"",COMP)
S LASTNAM=$P(NAME,COMP) ;LAST NAME
S FIRSTNAM=$P(NAME,COMP,2) ;FIRST NAME
S MIDNAME=$P(NAME,COMP,3) ;MIDDLE NAME
;
D MYSET(.ARY,"VTQ",0)
D MYSET(.ARY,DFN,1,1,1,1)
D MYSET(.ARY,"T",2,1,1,1)
D MYSET(.ARY,"EXACT_MATCH_QUERY",3,1,1,1)
D MYSET(.ARY,"ICN",4,1,1,1)
D MYSET(.ARY,"@OO108.1",5,1,1,1)
D MYSET(.ARY,"EQ",5,1,2,1)
D MYSET(.ARY,LASTNAME,5,1,3,1)
D MYSET(.ARY,"AND",5,1,4,1)
D MYSET(.ARY,"@00122",5,2,1,1)
D MYSET(.ARY,"EQ",5,2,2,1)
D MYSET(.ARY,SSN,5,2,3,1)
D MYSET(.ARY,"AND",5,2,4,1)
D MYSET(.ARY,"@00108.2",5,3,1,1)
D MYSET(.ARY,"EQ",5,3,2,1)
D MYSET(.ARY,FIRSTNAM,5,3,3,1)
D MYSET(.ARY,"AND",5,3,4,1)
D MYSET(.ARY,"@00110",5,4,1,1)
D MYSET(.ARY,"EQ",5,4,2,1)
D MYSET(.ARY,DOB,5,4,3,1)
D MYSET(.ARY,"AND",5,4,4,1)
D MYSET(.ARY,"@00111",5,5,1,1)
D MYSET(.ARY,"EQ",5,5,2,1)
D MYSET(.ARY,SEX,5,5,3,1)
D MYSET(.ARY,"AND",5,5,4,1)
D MYSET(.ARY,"@00108.3",5,6,1,1)
D MYSET(.ARY,"EQ",5,6,2,1)
D MYSET(.ARY,MIDNAME,5,6,3,1)
S VTQ=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
I $D(ERR) D NOTIF^AGMPIHLO(DFN,ERR)
Q
;
RDF(DFN) ;EP - CRATED RDF SEGMENT FOR VTQ MESSAGE
;"RDF^24^@00108.1~ST~30|@00122~ST~9|@00110~TS~8|@00756~ST~6|@00105~ST~1
;9|@00108.2~ST~30|@00169~ST~999|@00740~TS~8|@00108.3~ST~16|@00111~ST~1|@00126.1~S
;T~30|@00126.2~ST~3|@00108.5~ST~15|@00108.4~ST~10|@00109.1~ST~20|@ZEL6~ST~9|@CASE
;#~ST~69|@POW~ST~1|@00127~ST~1|@00112.1~ST~30|@00112.2~ST~25|@00112.3~ST~25|@0011
;2.5~ST~10|@00112.4~ST~10"
Q:'$G(DFN)
N RDF
;
D MYSET(.ARY,"RDF",0)
D MYSET(.ARY,1,1,1,1,1)
D MYSET(.ARY,"@OO108.1",2,1,1,1)
D MYSET(.ARY,"ST",2,1,2,1)
D MYSET(.ARY,30,2,1,3,1)
D MYSET(.ARY,"@00122",2,2,1,1)
D MYSET(.ARY,"ST",2,2,2,1)
D MYSET(.ARY,9,2,2,3,1)
D MYSET(.ARY,"@00110",2,3,1,1)
D MYSET(.ARY,"TS",2,3,2,1)
D MYSET(.ARY,"8",2,2,2,1)
D MYSET(.ARY,"@00756",2,4,1,1)
D MYSET(.ARY,"ST",2,4,2,1)
D MYSET(.ARY,"6",2,4,3,1)
D MYSET(.ARY,"@00105",2,5,1,1)
D MYSET(.ARY,"ST",2,5,2,1)
D MYSET(.ARY,"19",2,5,3,1)
D MYSET(.ARY,"@00108.2",2,6,1,1)
D MYSET(.ARY,"ST",2,6,2,1)
D MYSET(.ARY,"30",2,5,3,1)
D MYSET(.ARY,"@00169",2,7,1,1)
D MYSET(.ARY,"ST",2,7,2,1)
D MYSET(.ARY,"999",2,7,3,1)
D MYSET(.ARY,"@00740",2,8,1,1)
D MYSET(.ARY,"TS",2,8,2,1)
D MYSET(.ARY,"8",2,8,3,1)
D MYSET(.ARY,"@00108.3",2,9,1,1)
D MYSET(.ARY,"ST",2,9,2,1)
D MYSET(.ARY,"16",2,9,3,1)
D MYSET(.ARY,"@00111",2,10,1,1)
D MYSET(.ARY,"ST",2,10,2,1)
D MYSET(.ARY,"1",2,10,3,1)
D MYSET(.ARY,"@00126.1",2,11,1,1)
D MYSET(.ARY,"ST",2,11,2,1)
D MYSET(.ARY,"30",2,11,3,1)
D MYSET(.ARY,"@00126.2",2,12,1,1)
D MYSET(.ARY,"ST",2,12,2,1)
D MYSET(.ARY,"3",2,12,3,1)
D MYSET(.ARY,"@00108.5",2,13,1,1)
D MYSET(.ARY,"ST",2,13,2,1)
D MYSET(.ARY,"15",2,13,3,1)
D MYSET(.ARY,"@00108.4",2,14,1,1)
D MYSET(.ARY,"ST",2,14,2,1)
D MYSET(.ARY,"10",2,14,3,1)
D MYSET(.ARY,"@00109.1",2,15,1,1)
D MYSET(.ARY,"ST",2,15,2,1)
D MYSET(.ARY,"20",2,13,3,1)
D MYSET(.ARY,"@ZEL6",2,16,1,1)
D MYSET(.ARY,"ST",2,16,2,1)
D MYSET(.ARY,"9",2,16,3,1)
D MYSET(.ARY,"@CASE#",2,17,1,1)
D MYSET(.ARY,"ST",2,17,2,1)
D MYSET(.ARY,"69",2,17,3,1)
D MYSET(.ARY,"@POW",2,18,1,1)
D MYSET(.ARY,"ST",2,18,2,1)
D MYSET(.ARY,"1",2,18,3,1)
D MYSET(.ARY,"@00127",2,19,1,1)
D MYSET(.ARY,"ST",2,19,2,1)
D MYSET(.ARY,"1",2,19,3,1)
D MYSET(.ARY,"@00112.1",2,20,1,1)
D MYSET(.ARY,"ST",2,20,2,1)
D MYSET(.ARY,"30",2,20,3,1)
D MYSET(.ARY,"@00112.2",2,21,1,1)
D MYSET(.ARY,"ST",2,21,2,1)
D MYSET(.ARY,"25",2,21,3,1)
D MYSET(.ARY,"@00112.3",2,22,1,1)
D MYSET(.ARY,"ST",2,22,2,1)
D MYSET(.ARY,"25",2,22,3,1)
D MYSET(.ARY,"@00112.5",2,23,1,1)
D MYSET(.ARY,"ST",2,23,2,1)
D MYSET(.ARY,"10",2,23,3,1)
D MYSET(.ARY,"@00112.4",2,24,1,1)
D MYSET(.ARY,"ST",2,24,2,1)
D MYSET(.ARY,"10",2,24,3,1)
S RDF=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
I $D(ERR) D NOTIF^AGMPIHLO(DFN,ERR)
Q
ZPD(DFN) ;EP - RPMS SPECIFIC DATA
N TRIBEPTR,TRIBECOD,ELIGSTAT,BENPTR,BENCLASS,QUANTUM
S (BENCLASS,TRIBECOD,ELIGSTAT,QUANTUM)=""
S TRIBEPTR=$$GET1^DIQ(9000001,DFN_",",1108,"I") ;TRIBE OF MEMBERSHIP PTR
S:TRIBEPTR'="" TRIBECOD=$$GET1^DIQ(9999999.03,TRIBEPTR_",",.02,"I") ;TRIBE OF MEMBERSHIP CODE
S ELIGSTAT=$$GET1^DIQ(9000001,DFN_",",1112,"I") ;ELIGIBILITY STATUS
S BENPTR=$$GET1^DIQ(9000001,DFN_",",1111,"I") ;CLASSIFICATION/BENEFICIARY PTR
S:BENPTR'="" BENCLASS=$$GET1^DIQ(9999999.25,BENPTR_",",.02,"I") ;CLASSIFICATION/BENEFICIARY CODE
S QUANTUM=$$GET1^DIQ(9000001,DFN_",",1110,"I") ;INDIAN BLOOD QUANTUM
D MYSET(.ARY,"ZPD",0)
D MYSET(.ARY,1,1,1,1,1) ;ALWAYS 1
D MYSET(.ARY,TRIBECOD,2,1,1,1)
D MYSET(.ARY,ELIGSTAT,3,1,1,1)
D MYSET(.ARY,BENCLASS,4,1,1,1)
D MYSET(.ARY,QUANTUM,5,1,1,1)
;POPULATE THE CHARTS
D SCHART(DFN)
S X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
I $D(ERR) D NOTIF^AGMPIHLO(DFN,ERR)
Q
;
SCHART(IEN) ;EP - GET ACTIVE CHARTS
N INACTIVE,DUZ2,HRNREC,SEQ,UNIQID,SCHART,STAT
S INACTIVE=1
S SCHART=""
S DUZ2=0
;SET(SEG,VALUE,FIELD,REP,COMP,SUBCOMP)
F SEQ=1:1 S DUZ2=$O(^AUPNPAT(IEN,41,DUZ2)) Q:DUZ2="" D
.Q:$P($G(^AGFAC(DUZ2,0)),U,21)'="Y" ;ONLY OFFICAL REG. FACILITY
.S HRN=$P($G(^AUPNPAT(IEN,41,DUZ2,0)),U,2)
.S HRN=$$FILLSTR(HRN,10,"R","0")
.S HRNFAC=$P($G(^AUPNPAT(IEN,41,DUZ2,0)),U)
.S UNIQID=$$GET1^DIQ(9999999.06,HRNFAC_",",.32)
.S DATEINAC=$P($G(^AUPNPAT(IEN,41,DUZ2,0)),U,3) ;SEND INACTIVE DATE
.S:DATEINAC'="" DATEINAC=$$CONDT^AGMPHLU(DATEINAC) ;CHANGE FM DATE TO SQL NEXTGATE DATE
.S STAT=$$GET1^DIQ(4,DUZ2_",",99,"I")
.D MYSET(.ARY,STAT,6,SEQ,1,1)
.D MYSET(.ARY,HRN,6,SEQ,2,1)
.D MYSET(.ARY,HRNFAC,6,SEQ,3,1)
.D MYSET(.ARY,UNIQID,6,SEQ,4,1)
.D MYSET(.ARY,DATEINAC,6,SEQ,5,1)
Q
;
SALIAS(IEN) ;EP - GET ALIASES
N ALIASREC,COMPTR,ALIASDAT,SALIAS
;^DPT(8118,.01,1,0)=SHISH,KABOB^^464
S SALIAS=""
S ALIASREC=0
S SEQ=0
F S ALIASREC=$O(^DPT(IEN,.01,ALIASREC)) Q:'ALIASREC D
.S COMPTR=$P(^DPT(IEN,.01,ALIASREC,0),U,3)
.I 'COMPTR S SEQ=SEQ+1 D PARSE(ALIASREC) Q
.;Q:'COMPTR ;IF NO NAME COMPONENT PULL FROM DPT
.Q:'$D(^VA(20,COMPTR))
.S ALIASDAT=$G(^VA(20,COMPTR,1))
.Q:ALIASDAT=""
.S SEQ=SEQ+1
.S ALIASLST=$P(ALIASDAT,U)
.S ALIASFST=$P(ALIASDAT,U,2)
.S ALIASMID=$P(ALIASDAT,U,3)
.S ALIASPRE=$P(ALIASDAT,U,4)
.S ALIASSUF=$P(ALIASDAT,U,5)
.;SET(SEG,VALUE,FIELD,REP,COMP,SUBCOMP)
.D MYSET(.ARY,ALIASLST,9,SEQ,1,1)
.D MYSET(.ARY,ALIASFST,9,SEQ,2,1)
.D MYSET(.ARY,ALIASMID,9,SEQ,3,1)
.D MYSET(.ARY,ALIASPRE,9,SEQ,4,1)
.D MYSET(.ARY,ALIASSUF,9,SEQ,5,1)
Q
;
PARSE(ALIASREC) ;EP - PARSE ALIAS NAME
S COMP="~"
S ALIAS=$P($G(^DPT(IEN,.01,ALIASREC,0)),U)
S ALIASLST=$P(ALIAS,",")
S ALIASFST=$P($P(ALIAS,",",2)," ")
S ALIASMID=$P(ALIAS," ",2)
D MYSET(.ARY,ALIASLST,9,SEQ,1,1)
D MYSET(.ARY,ALIASFST,9,SEQ,2,1)
D MYSET(.ARY,ALIASMID,9,SEQ,3,1)
Q
;
FILLSTR(STR,LENGTH,JUST,FILLER) ;EP - FILL STRING TO FIXED LENGTH
N FILL
S LENGTH=$G(LENGTH),JUST=$G(JUST)
S STR=$E(STR,1,LENGTH)
Q:$L(STR)=LENGTH STR
S $P(FILL,FILLER,LENGTH-$L(STR)+1)=""
I JUST="L" S STR=STR_FILL
E S STR=FILL_STR
Q STR
;
MRG(DFN2) ;EP - CREATE MERGE SEGMENT
N ICN,NODE,NAME,FIRSTNM,LASTNAM,MIDNAME
S NODE=$$MPINODE^AGMPIPID(DFN2)
S ICN=$S($P(NODE,U)=-1:"",1:$P(NODE,U))_"V"_$S($P(NODE,U,2)?1.N:$P(NODE,U,2),1:"")
S NAME=$P(^DPT(DFN2,0),U)
S NAME=$$HLNAME^XLFNAME(NAME,"",COMP)
S LASTNAME=$P(NAME,COMP) ;LAST NAME
S FIRSTNAM=$P(NAME,COMP,2) ;FIRST NAME
S MIDNAME=$P(NAME,COMP,3) ;MIDDLE NAME
D MYSET(.ARY,"MRG",0)
D MYSET(.ARY,ICN,1,1,1,1)
D MYSET(.ARY,"USIHS",1,1,4,1)
D MYSET(.ARY,"0363",1,1,4,3)
D MYSET(.ARY,"NI",1,1,5,1)
D MYSET(.ARY,"IHS FACILIY ID",1,1,6,1)
D MYSET(.ARY,$P($$SITE^VASITE,"^",3),1,1,6,2)
D MYSET(.ARY,"L",1,1,6,3)
D MYSET(.ARY,DFN2,1,2,1,1)
D MYSET(.ARY,"NI",1,1,5,1)
D MYSET(.ARY,"USIHS",1,2,4,1)
D MYSET(.ARY,"0363",1,2,4,3)
D MYSET(.ARY,"PI",1,2,5,1)
D MYSET(.ARY,"IHS FACILIY ID",1,2,6,1)
D MYSET(.ARY,$P($$SITE^VASITE,"^",3),1,2,6,2)
D MYSET(.ARY,"L",1,2,6,3)
D MYSET(.ARY,LASTNAME,7,1,1,1)
D MYSET(.ARY,FIRSTNAM,7,1,2,1)
D MYSET(.ARY,MIDNAME,7,1,3,1)
D MYSET(.ARY,"L",7,1,7,1)
S X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
I $D(ERR) D NOTIF^AGMPIHLO(DFN,ERR)
Q
;SET(SEG,VALUE,FIELD,REP,COMP,SUBCOMP)
;THIS LOOKS MORE LIKE THE ARRAY WILL ACTUALLY TURN OUT
;AND ALSO MATCHES THE AGMPPARS V1.6 MESSAGE PARSER GENERIC OUTPUT
MYSET(ARY,V,F,R,C,S) ;EP
D SET^HLOAPI(.ARY,.V,.F,.C,.S,.R)
Q
AGMPIHL1 ;IHS/SD/TPF - Patient Registration MPI HLO Interface ext ALL HLO MESSAGES
+1 ;;7.2;IHS PATIENT REGISTRATION;**1**;JAN 07, 2011
+2 ;CALLED FROM AGMPIHLO
+3 QUIT
+4 ; Create PID segment
PID(DFN) ;EP
+1 NEW HRCN,FLD,LP,VAL,ASU,COMP,SUBCOMP
+2 IF '$GET(DFN)
SET ERR="DFN UNDEF IN PID^AGMPIHL1"
QUIT
+3 IF $GET(^DPT(DFN,0))=""
SET ERR="DPT 0 NODE FOR "_DFN_" NOT DEFINED IN PID^AGMPIHL1"
QUIT
+4 IF $PIECE($GET(^DPT(DFN,0)),U)=""
SET ERR="DPT 0 NODE P^1 "_DFN_"NOT POPULATED IN PID^AGMPIHL1"
QUIT
+5 ;PID(1)="PID^1^V^253032882P~~~USSSA&&0363~SS~VA FACILITY ID&14752&L|
+6 ;5571~~~USVHA&&0363~PI~VA FACILITY ID&14752&L
+7 ;^^GEGNUN~DELORES~M~~~~L^BUWSTRYNG~HARRY~M~~~~M^19820328^F^^^
+8 ;11419 3RD ST~~MORRIS~MN~~~P~|~~MINNEAPOLIS~MN~~~N^^(555)555-1732^^^^^^253032882P^^"
+9 ;PID(2)="^^MINNEAPOLIS MN^^^^^^^^"
+10 ;
+11 ;PID(1)="PID^1^V^V~~~USVHA&&0363~NI~VA FACILITY ID&14752&L|253032882P~~~USSSA&&03
+12 ;63~SS~VA FACILITY ID&14752&L|5571~~~USVHA&&0363~PI~VA FACILITY ID&14752&L^^GEGNU
+13 ;N~DELORES~M~~~~L^BUWSTRYNG~HARRY~M~~~~M^19820328^F^^^11419 3RD ST~~MORRIS~MN~~~P
+14 ;~|~~MINNEAPOL"
+15 ;PID(2)="IS~MN~~~N^^(555)555-1732^^^^^^253032882P^^^^MINNEAPOLIS MN^^^^^^^^
+16 SET FACNAME=$$GET1^DIQ(9999999.06,DUZ(2)_",",.01,"E")
+17 KILL PID,ERR
+18 DO BLDPID^AGMPIPID(DFN,1,"ALL",.PID,.HL1,.ERR)
+19 SET PID(1)=PID(1)_$GET(PID(2))
+20 DO MYSET(.ARY,"PID",0)
+21 ;ALWAYS 1
DO MYSET(.ARY,1,1,1,1,1)
+22 DO MYSET(.ARY,$PIECE(PID(1),HL1("FS"),3),2,1,1,1)
+23 DO MYSET(.ARY,$PIECE($PIECE(PID(1),HL1("FS"),4),"~"),3,1,1,1)
+24 DO MYSET(.ARY,"USIHS",3,1,4,1)
+25 ;THIS REFERS TO A TABLE BUT I CAN'T FIND IN VA DOC
DO MYSET(.ARY,"0363",3,1,4,3)
+26 DO MYSET(.ARY,"NI",3,1,5,1)
+27 DO MYSET(.ARY,"IHS FACILITY ID - "_FACNAME,3,1,6,1)
+28 DO MYSET(.ARY,$PIECE($$SITE^VASITE,"^",3),3,1,6,2)
+29 DO MYSET(.ARY,"L",3,1,6,3)
+30 DO MYSET(.ARY,$PIECE($PIECE(PID(1),"|",2),"~"),3,2,1,1)
+31 DO MYSET(.ARY,"USSSA",3,2,4,1)
+32 DO MYSET(.ARY,"0363",3,2,4,3)
+33 DO MYSET(.ARY,"SS",3,2,5,1)
+34 DO MYSET(.ARY,"IHS FACILITY ID - "_FACNAME,3,2,6,1)
+35 DO MYSET(.ARY,$PIECE($$SITE^VASITE,"^",3),3,2,6,2)
+36 DO MYSET(.ARY,"L",3,2,6,3)
+37 DO MYSET(.ARY,DFN,3,3,1,1)
+38 DO MYSET(.ARY,"USIHS",3,3,4,1)
+39 DO MYSET(.ARY,"0363",3,3,4,3)
+40 DO MYSET(.ARY,"PI",3,3,5,1)
+41 DO MYSET(.ARY,"IHS FACILITY ID - "_FACNAME,3,3,6,1)
+42 DO MYSET(.ARY,$PIECE($$SITE^VASITE,"^",3),3,3,6,2)
+43 DO MYSET(.ARY,"L",3,3,6,3)
+44 DO MYSET(.ARY,$PIECE(PID(1),HL1("FS"),3),3,4,1,1)
+45 DO MYSET(.ARY,"USIHS",3,4,4,1)
+46 DO MYSET(.ARY,"0363",3,4,4,3)
+47 DO MYSET(.ARY,"NI",3,4,5,1)
+48 DO MYSET(.ARY,"IHS FACILITY ID - "_FACNAME,3,4,6,1)
+49 DO MYSET(.ARY,$PIECE($$SITE^VASITE,"^",3),3,4,6,2)
+50 DO MYSET(.ARY,"L",3,4,6,3)
+51 DO MYSET(.ARY,"200910205571-0700",3,4,8,1)
+52 ;LAST NAME
DO MYSET(.ARY,$PIECE($PIECE(PID(1),HL1("FS"),6),"~"),5,1,1,1)
+53 ;FIRST NAME
DO MYSET(.ARY,$PIECE($PIECE(PID(1),HL1("FS"),6),"~",2),5,1,2,1)
+54 ;MIDDLE NAME
DO MYSET(.ARY,$PIECE($PIECE(PID(1),HL1("FS"),6),"~",3),5,1,3,1)
+55 DO MYSET(.ARY,$PIECE($PIECE(PID(1),HL1("FS"),6),"~",4),5,1,4,1)
+56 DO MYSET(.ARY,$PIECE($PIECE(PID(1),HL1("FS"),6),"~",5),5,1,5,1)
+57 DO MYSET(.ARY,$PIECE($PIECE(PID(1),HL1("FS"),6),"~",6),5,1,6,1)
+58 DO MYSET(.ARY,$PIECE($PIECE(PID(1),HL1("FS"),6),"~",7),5,1,7,1)
+59 DO MYSET(.ARY,$PIECE($PIECE(PID(1),HL1("FS"),7),"~"),6,1,1,1)
+60 DO MYSET(.ARY,$PIECE($PIECE(PID(1),HL1("FS"),7),"~",2),6,1,2,1)
+61 DO MYSET(.ARY,$PIECE($PIECE(PID(1),HL1("FS"),7),"~",3),6,1,3,1)
+62 DO MYSET(.ARY,$PIECE($PIECE(PID(1),HL1("FS"),7),"~",4),6,1,4,1)
+63 DO MYSET(.ARY,$PIECE($PIECE(PID(1),HL1("FS"),7),"~",5),6,1,5,1)
+64 DO MYSET(.ARY,$PIECE($PIECE(PID(1),HL1("FS"),7),"~",6),6,1,6,1)
+65 DO MYSET(.ARY,$PIECE($PIECE(PID(1),HL1("FS"),7),"~",7),6,1,7,1)
+66 ;DOB
DO MYSET(.ARY,$PIECE(PID(1),HL1("FS"),8),7,1,1,1)
+67 ;SEX
DO MYSET(.ARY,$PIECE(PID(1),HL1("FS"),9),8,1,1,1)
+68 DO MYSET(.ARY,$PIECE(PID(1),HL1("FS"),10),9,1,1,1)
+69 ;RACE
DO MYSET(.ARY,$PIECE(PID(1),HL1("FS"),11),10,1,1,1)
+70 ;FIRST LINE
DO MYSET(.ARY,$PIECE($PIECE(PID(1),HL1("FS"),12),"~"),11,1,1,1)
+71 ;SEC LINE
DO MYSET(.ARY,$PIECE($PIECE(PID(1),HL1("FS"),12),"~",2),11,1,2,1)
+72 ;CITY
DO MYSET(.ARY,$PIECE($PIECE(PID(1),HL1("FS"),12),"~",3),11,1,3,1)
+73 ;STATE
DO MYSET(.ARY,$PIECE($PIECE(PID(1),HL1("FS"),12),"~",4),11,1,4,1)
+74 ;ZIP
DO MYSET(.ARY,$PIECE($PIECE(PID(1),HL1("FS"),12),"~",5),11,1,5,1)
+75 DO MYSET(.ARY,$PIECE($PIECE(PID(1),HL1("FS"),12),"~",6),11,1,6,1)
+76 ;ADDRESS TYPE P=PERMANENT
DO MYSET(.ARY,$PIECE($PIECE(PID(1),HL1("FS"),12),"~",7),11,1,7,1)
+77 ;THIRD LINE
DO MYSET(.ARY,$PIECE($PIECE($PIECE(PID(1),HL1("FS"),12),"~",8),"|"),11,1,8,1)
+78 ;G CONTPID
+79 DO MYSET(.ARY,$PIECE($PIECE(PID(1),"|",4),"~"),11,2,3,1)
+80 DO MYSET(.ARY,$PIECE($PIECE(PID(1),"|",4),"~",2),11,2,2,1)
+81 DO MYSET(.ARY,$PIECE($PIECE(PID(1),"|",4),"~",3),11,2,3,1)
+82 DO MYSET(.ARY,$PIECE($PIECE(PID(1),"|",4),"~",4),11,2,4,1)
+83 DO MYSET(.ARY,$PIECE($PIECE(PID(1),"|",4),"~",5),11,2,5,1)
+84 DO MYSET(.ARY,$PIECE($PIECE(PID(1),"|",4),"~",6),11,2,6,1)
+85 ;address type
DO MYSET(.ARY,"N",11,2,7,1)
+86 ;
+87 ;DO ALIASES
+88 DO SALIAS(DFN)
+89 ;PID-13 PHONES AND EMAIL ;SET(SEG,VALUE,FIELD,COMP,SUBCOMP,REP)
+90 ;ADDED THESE FOR PAHSE 2
+91 ;PHONE #
DO MYSET(.ARY,$PIECE($PIECE(PID(1),HL1("FS"),14),"~"),13,1,1,1)
+92 ;PRIMARY
DO MYSET(.ARY,$PIECE($PIECE(PID(1),HL1("FS"),14),"~",2),13,1,2,1)
+93 ;PHONE
DO MYSET(.ARY,$PIECE($PIECE(PID(1),HL1("FS"),14),"~",3),13,1,3,1)
+94 ;PHONE #
DO MYSET(.ARY,$PIECE($PIECE(PID(1),HL1("FS"),15),"~"),13,2,1,1)
+95 ;WORK
DO MYSET(.ARY,$PIECE($PIECE(PID(1),HL1("FS"),15),"~",2),13,2,2,1)
+96 ;PHONE
DO MYSET(.ARY,$PIECE($PIECE(PID(1),HL1("FS"),15),"~",3),13,2,3,1)
+97 ;PHONE #
DO MYSET(.ARY,$PIECE($PIECE(PID(1),HL1("FS"),25),"~"),13,3,1,1)
+98 ;OTHER
DO MYSET(.ARY,$PIECE($PIECE(PID(1),HL1("FS"),25),"~",2),13,3,2,1)
+99 ;CELL
DO MYSET(.ARY,$PIECE($PIECE(PID(1),HL1("FS"),25),"~",3),13,3,3,1)
+100 ;EMAIL
DO MYSET(.ARY,$PIECE($PIECE(PID(1),HL1("FS"),26),"~"),13,4,1,1)
+101 ;NET
DO MYSET(.ARY,$PIECE($PIECE(PID(1),HL1("FS"),26),"~",2),13,4,2,1)
+102 ;INTERNET
DO MYSET(.ARY,$PIECE($PIECE(PID(1),HL1("FS"),26),"~",3),13,4,3,1)
+103 ;MARITAL STATUS
DO MYSET(.ARY,$PIECE(PID(1),HL1("FS"),17),16,1,1,1)
+104 ;RELIGION
DO MYSET(.ARY,$PIECE(PID(1),HL1("FS"),18),17,1,1,1)
+105 ;ETHNICITY
DO MYSET(.ARY,$PIECE(PID(1),HL1("FS"),23),22,1,1,1)
+106 ;VETERAN STATUS
DO MYSET(.ARY,$PIECE(PID(1),HL1("FS"),27),27,1,1,1)
+107 ;DATE OF DEATH
DO MYSET(.ARY,$PIECE(PID(1),HL1("FS"),29),29,1,1,1)
+108 ;
CONTPID ;EP -
+1 SET X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
+2 IF $DATA(ERR)
DO NOTIF^AGMPIHLO(DFN,ERR)
+3 QUIT
+4 ;
VTQ(DFN) ;EP - CREATE VTQ DIRECT CONNECT EXACT MATCH QUERY
+1 ;"VTQ^100127^T^EXACT_MATCH_QUERY^ICN^@00108.1~EQ~GOLDTEST~AND|@00122~EQ
+2 ;~153050678P~AND|@00108.2~EQ~ADD~AND|@00110~EQ~19780506~AND|@00111~EQ~F~AND|@0010
+3 ;8.3~EQ~NOSSN"
+4 IF '$GET(DFN)
QUIT
+5 NEW VTQ,SEX,DOB,NAME,FIRSTNAM,LASTNAM,MIDNAME,SSN
+6 ;
+7 SET SEX=$PIECE(^DPT(DFN,0),U,2)
+8 SET DOB=$PIECE(^DPT(DFN,0),U,3)
+9 SET DOB=$$HLDATE^HLFNC(DOB,"TS")
+10 SET SSN=$PIECE(^DPT(DFN,0),U,9)
+11 SET NAME=$PIECE(^DPT(DFN,0),U)
+12 SET NAME=$$HLNAME^XLFNAME(NAME,"",COMP)
+13 ;LAST NAME
SET LASTNAM=$PIECE(NAME,COMP)
+14 ;FIRST NAME
SET FIRSTNAM=$PIECE(NAME,COMP,2)
+15 ;MIDDLE NAME
SET MIDNAME=$PIECE(NAME,COMP,3)
+16 ;
+17 DO MYSET(.ARY,"VTQ",0)
+18 DO MYSET(.ARY,DFN,1,1,1,1)
+19 DO MYSET(.ARY,"T",2,1,1,1)
+20 DO MYSET(.ARY,"EXACT_MATCH_QUERY",3,1,1,1)
+21 DO MYSET(.ARY,"ICN",4,1,1,1)
+22 DO MYSET(.ARY,"@OO108.1",5,1,1,1)
+23 DO MYSET(.ARY,"EQ",5,1,2,1)
+24 DO MYSET(.ARY,LASTNAME,5,1,3,1)
+25 DO MYSET(.ARY,"AND",5,1,4,1)
+26 DO MYSET(.ARY,"@00122",5,2,1,1)
+27 DO MYSET(.ARY,"EQ",5,2,2,1)
+28 DO MYSET(.ARY,SSN,5,2,3,1)
+29 DO MYSET(.ARY,"AND",5,2,4,1)
+30 DO MYSET(.ARY,"@00108.2",5,3,1,1)
+31 DO MYSET(.ARY,"EQ",5,3,2,1)
+32 DO MYSET(.ARY,FIRSTNAM,5,3,3,1)
+33 DO MYSET(.ARY,"AND",5,3,4,1)
+34 DO MYSET(.ARY,"@00110",5,4,1,1)
+35 DO MYSET(.ARY,"EQ",5,4,2,1)
+36 DO MYSET(.ARY,DOB,5,4,3,1)
+37 DO MYSET(.ARY,"AND",5,4,4,1)
+38 DO MYSET(.ARY,"@00111",5,5,1,1)
+39 DO MYSET(.ARY,"EQ",5,5,2,1)
+40 DO MYSET(.ARY,SEX,5,5,3,1)
+41 DO MYSET(.ARY,"AND",5,5,4,1)
+42 DO MYSET(.ARY,"@00108.3",5,6,1,1)
+43 DO MYSET(.ARY,"EQ",5,6,2,1)
+44 DO MYSET(.ARY,MIDNAME,5,6,3,1)
+45 SET VTQ=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
+46 IF $DATA(ERR)
DO NOTIF^AGMPIHLO(DFN,ERR)
+47 QUIT
+48 ;
RDF(DFN) ;EP - CRATED RDF SEGMENT FOR VTQ MESSAGE
+1 ;"RDF^24^@00108.1~ST~30|@00122~ST~9|@00110~TS~8|@00756~ST~6|@00105~ST~1
+2 ;9|@00108.2~ST~30|@00169~ST~999|@00740~TS~8|@00108.3~ST~16|@00111~ST~1|@00126.1~S
+3 ;T~30|@00126.2~ST~3|@00108.5~ST~15|@00108.4~ST~10|@00109.1~ST~20|@ZEL6~ST~9|@CASE
+4 ;#~ST~69|@POW~ST~1|@00127~ST~1|@00112.1~ST~30|@00112.2~ST~25|@00112.3~ST~25|@0011
+5 ;2.5~ST~10|@00112.4~ST~10"
+6 IF '$GET(DFN)
QUIT
+7 NEW RDF
+8 ;
+9 DO MYSET(.ARY,"RDF",0)
+10 DO MYSET(.ARY,1,1,1,1,1)
+11 DO MYSET(.ARY,"@OO108.1",2,1,1,1)
+12 DO MYSET(.ARY,"ST",2,1,2,1)
+13 DO MYSET(.ARY,30,2,1,3,1)
+14 DO MYSET(.ARY,"@00122",2,2,1,1)
+15 DO MYSET(.ARY,"ST",2,2,2,1)
+16 DO MYSET(.ARY,9,2,2,3,1)
+17 DO MYSET(.ARY,"@00110",2,3,1,1)
+18 DO MYSET(.ARY,"TS",2,3,2,1)
+19 DO MYSET(.ARY,"8",2,2,2,1)
+20 DO MYSET(.ARY,"@00756",2,4,1,1)
+21 DO MYSET(.ARY,"ST",2,4,2,1)
+22 DO MYSET(.ARY,"6",2,4,3,1)
+23 DO MYSET(.ARY,"@00105",2,5,1,1)
+24 DO MYSET(.ARY,"ST",2,5,2,1)
+25 DO MYSET(.ARY,"19",2,5,3,1)
+26 DO MYSET(.ARY,"@00108.2",2,6,1,1)
+27 DO MYSET(.ARY,"ST",2,6,2,1)
+28 DO MYSET(.ARY,"30",2,5,3,1)
+29 DO MYSET(.ARY,"@00169",2,7,1,1)
+30 DO MYSET(.ARY,"ST",2,7,2,1)
+31 DO MYSET(.ARY,"999",2,7,3,1)
+32 DO MYSET(.ARY,"@00740",2,8,1,1)
+33 DO MYSET(.ARY,"TS",2,8,2,1)
+34 DO MYSET(.ARY,"8",2,8,3,1)
+35 DO MYSET(.ARY,"@00108.3",2,9,1,1)
+36 DO MYSET(.ARY,"ST",2,9,2,1)
+37 DO MYSET(.ARY,"16",2,9,3,1)
+38 DO MYSET(.ARY,"@00111",2,10,1,1)
+39 DO MYSET(.ARY,"ST",2,10,2,1)
+40 DO MYSET(.ARY,"1",2,10,3,1)
+41 DO MYSET(.ARY,"@00126.1",2,11,1,1)
+42 DO MYSET(.ARY,"ST",2,11,2,1)
+43 DO MYSET(.ARY,"30",2,11,3,1)
+44 DO MYSET(.ARY,"@00126.2",2,12,1,1)
+45 DO MYSET(.ARY,"ST",2,12,2,1)
+46 DO MYSET(.ARY,"3",2,12,3,1)
+47 DO MYSET(.ARY,"@00108.5",2,13,1,1)
+48 DO MYSET(.ARY,"ST",2,13,2,1)
+49 DO MYSET(.ARY,"15",2,13,3,1)
+50 DO MYSET(.ARY,"@00108.4",2,14,1,1)
+51 DO MYSET(.ARY,"ST",2,14,2,1)
+52 DO MYSET(.ARY,"10",2,14,3,1)
+53 DO MYSET(.ARY,"@00109.1",2,15,1,1)
+54 DO MYSET(.ARY,"ST",2,15,2,1)
+55 DO MYSET(.ARY,"20",2,13,3,1)
+56 DO MYSET(.ARY,"@ZEL6",2,16,1,1)
+57 DO MYSET(.ARY,"ST",2,16,2,1)
+58 DO MYSET(.ARY,"9",2,16,3,1)
+59 DO MYSET(.ARY,"@CASE#",2,17,1,1)
+60 DO MYSET(.ARY,"ST",2,17,2,1)
+61 DO MYSET(.ARY,"69",2,17,3,1)
+62 DO MYSET(.ARY,"@POW",2,18,1,1)
+63 DO MYSET(.ARY,"ST",2,18,2,1)
+64 DO MYSET(.ARY,"1",2,18,3,1)
+65 DO MYSET(.ARY,"@00127",2,19,1,1)
+66 DO MYSET(.ARY,"ST",2,19,2,1)
+67 DO MYSET(.ARY,"1",2,19,3,1)
+68 DO MYSET(.ARY,"@00112.1",2,20,1,1)
+69 DO MYSET(.ARY,"ST",2,20,2,1)
+70 DO MYSET(.ARY,"30",2,20,3,1)
+71 DO MYSET(.ARY,"@00112.2",2,21,1,1)
+72 DO MYSET(.ARY,"ST",2,21,2,1)
+73 DO MYSET(.ARY,"25",2,21,3,1)
+74 DO MYSET(.ARY,"@00112.3",2,22,1,1)
+75 DO MYSET(.ARY,"ST",2,22,2,1)
+76 DO MYSET(.ARY,"25",2,22,3,1)
+77 DO MYSET(.ARY,"@00112.5",2,23,1,1)
+78 DO MYSET(.ARY,"ST",2,23,2,1)
+79 DO MYSET(.ARY,"10",2,23,3,1)
+80 DO MYSET(.ARY,"@00112.4",2,24,1,1)
+81 DO MYSET(.ARY,"ST",2,24,2,1)
+82 DO MYSET(.ARY,"10",2,24,3,1)
+83 SET RDF=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
+84 IF $DATA(ERR)
DO NOTIF^AGMPIHLO(DFN,ERR)
+85 QUIT
ZPD(DFN) ;EP - RPMS SPECIFIC DATA
+1 NEW TRIBEPTR,TRIBECOD,ELIGSTAT,BENPTR,BENCLASS,QUANTUM
+2 SET (BENCLASS,TRIBECOD,ELIGSTAT,QUANTUM)=""
+3 ;TRIBE OF MEMBERSHIP PTR
SET TRIBEPTR=$$GET1^DIQ(9000001,DFN_",",1108,"I")
+4 ;TRIBE OF MEMBERSHIP CODE
IF TRIBEPTR'=""
SET TRIBECOD=$$GET1^DIQ(9999999.03,TRIBEPTR_",",.02,"I")
+5 ;ELIGIBILITY STATUS
SET ELIGSTAT=$$GET1^DIQ(9000001,DFN_",",1112,"I")
+6 ;CLASSIFICATION/BENEFICIARY PTR
SET BENPTR=$$GET1^DIQ(9000001,DFN_",",1111,"I")
+7 ;CLASSIFICATION/BENEFICIARY CODE
IF BENPTR'=""
SET BENCLASS=$$GET1^DIQ(9999999.25,BENPTR_",",.02,"I")
+8 ;INDIAN BLOOD QUANTUM
SET QUANTUM=$$GET1^DIQ(9000001,DFN_",",1110,"I")
+9 DO MYSET(.ARY,"ZPD",0)
+10 ;ALWAYS 1
DO MYSET(.ARY,1,1,1,1,1)
+11 DO MYSET(.ARY,TRIBECOD,2,1,1,1)
+12 DO MYSET(.ARY,ELIGSTAT,3,1,1,1)
+13 DO MYSET(.ARY,BENCLASS,4,1,1,1)
+14 DO MYSET(.ARY,QUANTUM,5,1,1,1)
+15 ;POPULATE THE CHARTS
+16 DO SCHART(DFN)
+17 SET X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
+18 IF $DATA(ERR)
DO NOTIF^AGMPIHLO(DFN,ERR)
+19 QUIT
+20 ;
SCHART(IEN) ;EP - GET ACTIVE CHARTS
+1 NEW INACTIVE,DUZ2,HRNREC,SEQ,UNIQID,SCHART,STAT
+2 SET INACTIVE=1
+3 SET SCHART=""
+4 SET DUZ2=0
+5 ;SET(SEG,VALUE,FIELD,REP,COMP,SUBCOMP)
+6 FOR SEQ=1:1
SET DUZ2=$ORDER(^AUPNPAT(IEN,41,DUZ2))
IF DUZ2=""
QUIT
Begin DoDot:1
+7 ;ONLY OFFICAL REG. FACILITY
IF $PIECE($GET(^AGFAC(DUZ2,0)),U,21)'="Y"
QUIT
+8 SET HRN=$PIECE($GET(^AUPNPAT(IEN,41,DUZ2,0)),U,2)
+9 SET HRN=$$FILLSTR(HRN,10,"R","0")
+10 SET HRNFAC=$PIECE($GET(^AUPNPAT(IEN,41,DUZ2,0)),U)
+11 SET UNIQID=$$GET1^DIQ(9999999.06,HRNFAC_",",.32)
+12 ;SEND INACTIVE DATE
SET DATEINAC=$PIECE($GET(^AUPNPAT(IEN,41,DUZ2,0)),U,3)
+13 ;CHANGE FM DATE TO SQL NEXTGATE DATE
IF DATEINAC'=""
SET DATEINAC=$$CONDT^AGMPHLU(DATEINAC)
+14 SET STAT=$$GET1^DIQ(4,DUZ2_",",99,"I")
+15 DO MYSET(.ARY,STAT,6,SEQ,1,1)
+16 DO MYSET(.ARY,HRN,6,SEQ,2,1)
+17 DO MYSET(.ARY,HRNFAC,6,SEQ,3,1)
+18 DO MYSET(.ARY,UNIQID,6,SEQ,4,1)
+19 DO MYSET(.ARY,DATEINAC,6,SEQ,5,1)
End DoDot:1
+20 QUIT
+21 ;
SALIAS(IEN) ;EP - GET ALIASES
+1 NEW ALIASREC,COMPTR,ALIASDAT,SALIAS
+2 ;^DPT(8118,.01,1,0)=SHISH,KABOB^^464
+3 SET SALIAS=""
+4 SET ALIASREC=0
+5 SET SEQ=0
+6 FOR
SET ALIASREC=$ORDER(^DPT(IEN,.01,ALIASREC))
IF 'ALIASREC
QUIT
Begin DoDot:1
+7 SET COMPTR=$PIECE(^DPT(IEN,.01,ALIASREC,0),U,3)
+8 IF 'COMPTR
SET SEQ=SEQ+1
DO PARSE(ALIASREC)
QUIT
+9 ;Q:'COMPTR ;IF NO NAME COMPONENT PULL FROM DPT
+10 IF '$DATA(^VA(20,COMPTR))
QUIT
+11 SET ALIASDAT=$GET(^VA(20,COMPTR,1))
+12 IF ALIASDAT=""
QUIT
+13 SET SEQ=SEQ+1
+14 SET ALIASLST=$PIECE(ALIASDAT,U)
+15 SET ALIASFST=$PIECE(ALIASDAT,U,2)
+16 SET ALIASMID=$PIECE(ALIASDAT,U,3)
+17 SET ALIASPRE=$PIECE(ALIASDAT,U,4)
+18 SET ALIASSUF=$PIECE(ALIASDAT,U,5)
+19 ;SET(SEG,VALUE,FIELD,REP,COMP,SUBCOMP)
+20 DO MYSET(.ARY,ALIASLST,9,SEQ,1,1)
+21 DO MYSET(.ARY,ALIASFST,9,SEQ,2,1)
+22 DO MYSET(.ARY,ALIASMID,9,SEQ,3,1)
+23 DO MYSET(.ARY,ALIASPRE,9,SEQ,4,1)
+24 DO MYSET(.ARY,ALIASSUF,9,SEQ,5,1)
End DoDot:1
+25 QUIT
+26 ;
PARSE(ALIASREC) ;EP - PARSE ALIAS NAME
+1 SET COMP="~"
+2 SET ALIAS=$PIECE($GET(^DPT(IEN,.01,ALIASREC,0)),U)
+3 SET ALIASLST=$PIECE(ALIAS,",")
+4 SET ALIASFST=$PIECE($PIECE(ALIAS,",",2)," ")
+5 SET ALIASMID=$PIECE(ALIAS," ",2)
+6 DO MYSET(.ARY,ALIASLST,9,SEQ,1,1)
+7 DO MYSET(.ARY,ALIASFST,9,SEQ,2,1)
+8 DO MYSET(.ARY,ALIASMID,9,SEQ,3,1)
+9 QUIT
+10 ;
FILLSTR(STR,LENGTH,JUST,FILLER) ;EP - FILL STRING TO FIXED LENGTH
+1 NEW FILL
+2 SET LENGTH=$GET(LENGTH)
SET JUST=$GET(JUST)
+3 SET STR=$EXTRACT(STR,1,LENGTH)
+4 IF $LENGTH(STR)=LENGTH
QUIT STR
+5 SET $PIECE(FILL,FILLER,LENGTH-$LENGTH(STR)+1)=""
+6 IF JUST="L"
SET STR=STR_FILL
+7 IF '$TEST
SET STR=FILL_STR
+8 QUIT STR
+9 ;
MRG(DFN2) ;EP - CREATE MERGE SEGMENT
+1 NEW ICN,NODE,NAME,FIRSTNM,LASTNAM,MIDNAME
+2 SET NODE=$$MPINODE^AGMPIPID(DFN2)
+3 SET ICN=$SELECT($PIECE(NODE,U)=-1:"",1:$PIECE(NODE,U))_"V"_$SELECT($PIECE(NODE,U,2)?1.N:$PIECE(NODE,U,2),1:"")
+4 SET NAME=$PIECE(^DPT(DFN2,0),U)
+5 SET NAME=$$HLNAME^XLFNAME(NAME,"",COMP)
+6 ;LAST NAME
SET LASTNAME=$PIECE(NAME,COMP)
+7 ;FIRST NAME
SET FIRSTNAM=$PIECE(NAME,COMP,2)
+8 ;MIDDLE NAME
SET MIDNAME=$PIECE(NAME,COMP,3)
+9 DO MYSET(.ARY,"MRG",0)
+10 DO MYSET(.ARY,ICN,1,1,1,1)
+11 DO MYSET(.ARY,"USIHS",1,1,4,1)
+12 DO MYSET(.ARY,"0363",1,1,4,3)
+13 DO MYSET(.ARY,"NI",1,1,5,1)
+14 DO MYSET(.ARY,"IHS FACILIY ID",1,1,6,1)
+15 DO MYSET(.ARY,$PIECE($$SITE^VASITE,"^",3),1,1,6,2)
+16 DO MYSET(.ARY,"L",1,1,6,3)
+17 DO MYSET(.ARY,DFN2,1,2,1,1)
+18 DO MYSET(.ARY,"NI",1,1,5,1)
+19 DO MYSET(.ARY,"USIHS",1,2,4,1)
+20 DO MYSET(.ARY,"0363",1,2,4,3)
+21 DO MYSET(.ARY,"PI",1,2,5,1)
+22 DO MYSET(.ARY,"IHS FACILIY ID",1,2,6,1)
+23 DO MYSET(.ARY,$PIECE($$SITE^VASITE,"^",3),1,2,6,2)
+24 DO MYSET(.ARY,"L",1,2,6,3)
+25 DO MYSET(.ARY,LASTNAME,7,1,1,1)
+26 DO MYSET(.ARY,FIRSTNAM,7,1,2,1)
+27 DO MYSET(.ARY,MIDNAME,7,1,3,1)
+28 DO MYSET(.ARY,"L",7,1,7,1)
+29 SET X=$$ADDSEG^HLOAPI(.HLST,.ARY,.ERR)
+30 IF $DATA(ERR)
DO NOTIF^AGMPIHLO(DFN,ERR)
+31 QUIT
+32 ;SET(SEG,VALUE,FIELD,REP,COMP,SUBCOMP)
+33 ;THIS LOOKS MORE LIKE THE ARRAY WILL ACTUALLY TURN OUT
+34 ;AND ALSO MATCHES THE AGMPPARS V1.6 MESSAGE PARSER GENERIC OUTPUT
MYSET(ARY,V,F,R,C,S) ;EP
+1 DO SET^HLOAPI(.ARY,.V,.F,.C,.S,.R)
+2 QUIT
