- 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