AGAPIS ;IHS/SD/TPF - PATIENT REGISTRATION ELIGIBLITY API CALL
;;7.1;PATIENT REGISTRATION;**2,12**;AUG 25, 2005;Build 1
;
;IHS/OIT/NKD AG*7.1*12 INSURER TYPE
;
W !,"DO NOT CALL FROM ROOT!"
Q
;
;GENERAL LOGIC:
;
;USING THE "EFF" CROSS REFERENCE IN THE "CATEGORY PRIORITIZING" FILE
;#9000035 FIND ALL PRIORITIZED CATEGORIES FOR THE PATIENT DFN (AGGIEN)
;WHICH ARE EFFECTIVE (EFFECTIVE DATE OF PRIORITY (#.06) ) AS
;OF THE DATE OF SERVICE (AGGDOS).
;
;NEXT, ELIMINATE ANY ENTRIES IN THE ELIGIBILITY FILE WHICH ARE FOUND TO
;BE NON-ACTIVE GIVEN THE DATE OF SERVICE (AGGDOS). THE DATE OF SERVICE
;IS COMPARED TO THE 'BEGIN' AND ENDING DATES OF COVERAGE FOUND IN THE
;APPROPRIATE ELIGIBLITY FILE.
;
;IF THE ELIGIBILITY ENTRY IS FOUND TO BE ACTIVE THEN THE CATEGORY AND
;ELIGIBILITY DATA IS ADDED TO THE RETURNED ARRAY
;OR STRING IF AGGBMX=1.
;
;THE RETURNED ARRAY HAS THE FOLLOWING BASIC STRUCTURE:
;
; AGGXY(CATEGORY,PRIORITY,INSURER POINTER,File #, fda iens,
; Field#/Field Name, [Internal/External])=DATA
;
;THE SUBSCRIPT STRUCTURE BEYOND THE INSURER POINTER (THIRD SUBSCRIPT) IS
;IN THE FORM OF A STANDARD FDA ARRAY RETURNED BY THE FIELMAN DBS API
;$$GETS^DIQ() Data Retriever AND IS DEPENDENT UPON THE FLAGS PASSED VIA
;PARAMETER AGGFLAG. SEE "VA FILEMAN V. 22.0 PROGRAMMER MANUAL"
;PAGE 2-186 FOR DETAILS ON WHAT THE FLAGS MEAN. KEEP IN MIND THE
;RETURNED ARRAY'S STRUCTURE CHANGES DEPENDING ON THE FLAGS BEING PASSED.
;NOTE: THE 'INSURER POINTER' SUBSCRIPT FOR THE GUARANTOR WILL BE THE
;GLOBAL RFERENCE TO THE ACTUAL GUARANTOR
; E.G.
; AGGXY("T",1,"AUPNPAT(5571,0)","9000003.1","97,",".01","E")="GEGNUN,DELORES M"
;
;IN THE CASE ABOVE, THE GUARANTOR IS THE PATIENT. THE GUARANTOR
;AS OF THIS PATCH CAN BE A PATIENT, AN INSURER OR AN EMPLOYER
;
;IF AGGBMX=1 THEN THE BMXNet STRING IS RETURNED. IT'S FORMAT IS THE
;SAME AS THE BMXNet STRUCTURE FOR STATIC TABLES. SEE PAGES 8-9 OF THE
;"BMXNet ADO.NET Data Access and Connectivity Utilities for RPMS User
;Manual" FOR A DESCRIPTION OF THIS STRUCTURE.
;
;PARAMETERS:
;AGGXY = RETURNED DATA ARRAY OR STRING
;AGGIEN = PATIENT'S DFN. if null error message returned
;AGGDOS = DATE OF SERVICE
; If null, AGGDOS=DT
;
;AGGFLAG = STANDARD FLAGS FOR GETS^DIQ CALL
; "I" = INTERNAL
; "E" = EXTERNAL VALUES (DEFAULT)
; "N" = DON'T RETURN NULL VALUES
; "R" = RESOLVE FILE NUMBERS TO NAMES
;
; if null the default is "E"
;
;AGGCAT = A ^ DELIMITED STRING CONTAINING THE CATEGORIES REQUESTED
; 'M' FOR MEDICAL;
; 'D' FOR DENTAL;
; 'O' FOR OPTOMETRY;
; 'R' FOR PHARMACY;
; 'P' FOR MENTAL HEALTH;
; 'A' FOR AUTO ACCIDENT/TORT; This is the same
; as third party liability
; 'W' FOR WORKMAN'S COMP;
;
; E.G. ^M^A^W^
;
; WILL RETURN MEDICAL,AUTO ACCIDENT AND WORKMEN'S COM
; CATEGORIES.
; if null the default is ALL CATEGORIES
;
;AGGBMX = IF 1 THEN DATA IS RETURNED IN BMXNET FORMAT
; IF 0 THEN DATA IS RETURNED IN ARRAY FORMAT DESCRIBED ABOVE
; if null the default is 0
;
;IF NO EFFECTIVE SEQUENCE CATEGORIES ARE FOUND:
; 1) THE BMXNET CALLER WIL RECEIVE THE COLUMN SCHEMA WITH NO RECORDS
; E.G. AGGXY="T00004CATEGORY^N000030PRIORITY^N000030INSURER^
; N000030FILE_NUMBER^F000030FDA_IENS^F000050FIELD^
; F000080DATA^"
;
; 2) AGGXY WILL BE UNDEFINED FOR A NON BMXNET CALLER
; D GETELIG^AGAPIS(.LJF,10416,DT,"ER","",0)
GETELIG(AGGXY,AGGIEN,AGGDOS,AGGFLAG,AGGCAT,AGGBMX) ;PEP - API ENTRY FOR ACTIVE INSURANCE COVERAGE
N PATIEN,RECORD,FLD,AGGDATA,AGGRET,AGGRETMP,CATPRIOR
I '$D(^AUPNPAT(AGGIEN))!'$D(^DPT(AGGIEN)) S AGGXY="T00040ERROR"_$C(30)_"Patient not in either PATIENT or VA PATIENT file"_$C(30)_$C(31) Q
I $G(AGGCAT)'="" D
.I $E(AGGCAT)'=U S AGGCAT=U_AGGCAT
.I $E(AGGCAT,$L(AGGCAT))'=U S AGGCAT=AGGCAT_U
I $G(AGGIEN)="",$G(AGGBMX) S AGGXY="T00040ERROR"_$C(30)_"No patient IEN"_$C(30)_$C(31) Q
I $G(AGGIEN)="" K AGGXY Q
S:$G(AGGBMX)="" AGGBMX=0
S:$G(AGGDOS)="" AGGDOS=DT
S:$G(AGGCAT)'="" AGGCAT=$$UPPER(AGGCAT)
S:AGGFLAG'="" AGGFLAG=$$UPPER(AGGFLAG)
S:$G(AGGCAT)="" AGGCAT=$$GETCODES()
S:$G(AGGFLAG)="" AGGFLAG="E"
S AGGRETMP=""
;GO THROUGH THE CATEGORIES AND GRAB ONLY THOSE SELECTED IN AGGCAT
S CAT=""
F S CAT=$O(^AUPNICP("EFF",AGGIEN,CAT)) Q:CAT="" D
.Q:AGGCAT'[(U_CAT_U)
.S EFFDT=$O(^AUPNICP("EFF",AGGIEN,CAT,AGGDOS+.01),-1)
.Q:EFFDT=""
.S RECORD=""
.F S RECORD=$O(^AUPNICP("EFF",AGGIEN,CAT,EFFDT,RECORD)) Q:RECORD="" D
..K AGGDATA,AGGERR
..;GET DATA FROM 'CATEGORY PRIORITIZING' FILE
..D GETS^DIQ(9000035,RECORD,"*","I","AGGDATA","AGGERR")
..I $D(AGGERR) Q
..M AGGRETMP=AGGDATA
;GO GET INSURANCE ELIGIBILITY
K CATPRIOR
D GETINS(.AGGRETMP,.CATPRIOR)
D DELOBSOL(.CATPRIOR) ;DELETE OBSOLETE FIELDS MARKED WITH '*' IN NAME
;HERE WE SHOULD HAVE A LIST OF ALL ACTIVE SEQ. ELIGIBILITIES SORTED IN CATPRIOR
I 'AGGBMX M AGGXY=CATPRIOR D CLEAN Q
;OTHERWISE SEND BACK A BMX RECORD SET
D BMXHDR(.HDR)
D BMXSET(.CATPRIOR,.AGGXY)
S AGGXY=HDR_$C(30)_AGGXY_$C(30)
D CLEAN
Q
;GET ELIGIBLITY INFO AND SORT BY CATEGORY,PRIORITY AND INSURER
GETINS(AGGELIG,CATPRIOR) ;
S RECORD=""
;SORT THE CATEGORIZED ENTRIES BY CATEGORY AND PRIORITY
F S RECORD=$O(AGGELIG(9000035,RECORD)) Q:RECORD="" D
.S RECPTR=$G(AGGELIG(9000035,RECORD,".15","I"))
.S INSPTR=$G(AGGELIG(9000035,RECORD,".03","I"))
.S PRIORITY=$G(AGGELIG(9000035,RECORD,".05","I"))
.S CATEGORY=$G(AGGELIG(9000035,RECORD,.04,"I"))
.S COVTYPE=$G(AGGELIG(9000035,RECORD,.07,"I"))
.S CATPRIOR(CATEGORY,PRIORITY,INSPTR)=RECPTR_"|"_COVTYPE
;
;NOW GET THE ELIGIBILITY DATA
S CATEGORY=""
F S CATEGORY=$O(CATPRIOR(CATEGORY)) Q:CATEGORY="" D
.S PRIORITY=""
.F S PRIORITY=$O(CATPRIOR(CATEGORY,PRIORITY)) Q:PRIORITY="" D
..S INSPTR=""
..S INSPTR=$O(CATPRIOR(CATEGORY,PRIORITY,INSPTR)) Q:INSPTR="" D
...K AGGERR,AGGDATA
...;GET INSURER TYPE FROM INSURER FILE
...I $P(CATPRIOR(CATEGORY,PRIORITY,INSPTR),"|",2)="G" D
....S INSTYPE="GUARANTOR"
...;E S INSTYPE=$$GET1^DIQ(9999999.18,INSPTR,.21,"E","AGGINS","AGGERR")
...E S INSTYPE=$$INSTYP^AGUTL(INSPTR,1) ;IHS/OIT/NKD AG*7.1*12
...S RECPTR=$P(CATPRIOR(CATEGORY,PRIORITY,INSPTR),"|")
...S COVTYPE=$P(CATPRIOR(CATEGORY,PRIORITY,INSPTR),"|",2)
...I INSPTR=1,(COVTYPE'="D") D GETRRAB^AGAPIS1(.CATPRIOR) Q ;RAILROAD RETIRMENT A & B
...I INSPTR=2,(COVTYPE'="D") D GETMCRAB^AGAPIS1(.CATPRIOR) Q ;MEDICARE A & B
...I INSPTR=3 D GETMCD^AGAPIS1(.CATPRIOR) Q ;MEDICAID
...I INSPTR=1,(COVTYPE="D") D GETRRD^AGAPIS1(.CATPRIOR) Q ;RAILROAD RETIREMENT PART D
...I INSPTR=2,(COVTYPE="D") D GETMCRD^AGAPIS1(.CATPRIOR) Q ;MEDICARE PART D
...I INSTYPE="MCR PART D",(COVTYPE="D") D GETMCRD^AGAPIS1(.CATPRIOR) Q ;MEDICARE PART D
...I INSTYPE="GUARANTOR" D GETGUAR^AGAPIS1(.CATPRIOR) Q
...I INSTYPE="THIRD PARTY LIABILITY" D GETTPL^AGAPIS1(.CATPRIOR) Q
...I INSTYPE="WORKMEN'S COMP." D WCOMP^AGAPIS1(.CATPRIOR) Q
...;ALL OTHERS SHOULD BE PRIVATE INSURANCE
...D GETPRVT^AGAPIS1(.CATPRIOR)
...K AGGDATA,AGGERR
Q
CLEAN ;
K AGCODES,AGGRET,AGGDATA,AGGFLAG,AGGFILE,FIELDTYP,AGGHDR,AGGZERO
K RECORD,AGCODES,AGGRETMP,AGCDSTR,CAT,CATEGORY,COVTYPE,EFFDT,INSPTR,INSTYPE,POLHPTR
K PRIORITY,RECPTR,TPRECPTR,SBRECPTR,FILENO,DATA,FIELDS,FDAIENS,AGGINS,AGGPOLH
K X,Y,HDR,AGGFIELD
Q
;CREATE BMXNET COLUMN HEADER FOR BMX RECORD SET
BMXHDR(HDR) ;
S HDR="T00004CATEGORY"_U
S HDR=HDR_"N000030PRIORITY"_U
S HDR=HDR_"N000030INSURER"_U
S HDR=HDR_"N000030FILE_NUMBER"_U
S HDR=HDR_"F000030FDA_IENS"_U
S HDR=HDR_"F000050FIELD"_U
S HDR=HDR_"F000080DATA"
Q HDR
;CREATE BMXNET RECORD SET TO SEND BACK TO CLIENT
BMXSET(CATPRIOR,AGGXY) ;
N AGGRET
S AGGRET=""
S CATEGORY=""
F S CATEGORY=$O(CATPRIOR(CATEGORY)) Q:CATEGORY="" D
.S PRIORITY=""
.F S PRIORITY=$O(CATPRIOR(CATEGORY,PRIORITY)) Q:PRIORITY="" D
..S INSPTR=""
..F S INSPTR=$O(CATPRIOR(CATEGORY,PRIORITY,INSPTR)) Q:INSPTR="" D
...S FILENO=""
...F S FILENO=$O(CATPRIOR(CATEGORY,PRIORITY,INSPTR,FILENO)) Q:FILENO="" D
....S FDAIENS=""
....F S FDAIENS=$O(CATPRIOR(CATEGORY,PRIORITY,INSPTR,FILENO,FDAIENS)) Q:FDAIENS="" D
.....S FIELD=""
.....F S FIELD=$O(CATPRIOR(CATEGORY,PRIORITY,INSPTR,FILENO,FDAIENS,FIELD)) Q:FIELD="" D
......S DATA=$G(CATPRIOR(CATEGORY,PRIORITY,INSPTR,FILENO,FDAIENS,FIELD))
......S:DATA="" DATA=$G(CATPRIOR(CATEGORY,PRIORITY,INSPTR,FILENO,FDAIENS,FIELD,"I"))
......S:DATA="" DATA=$G(CATPRIOR(CATEGORY,PRIORITY,INSPTR,FILENO,FDAIENS,FIELD,"E"))
......S AGGRET=AGGRET_CATEGORY_U_PRIORITY_U_INSPTR_U_FILENO_U_FDAIENS_U_FIELD_U_DATA_$C(30)
......;W !,AGGRET
M AGGXY=AGGRET
Q
GETCODES() ;
S AGZERO=$G(^DD(9000035,.04,0)),AGCDSTR=$P(AGZERO,U,3)
S AGCODES=U
F PIECE=1:1 Q:$P($P(AGCDSTR,";",PIECE),":")="" S AGCODES=AGCODES_$S($P($P(AGCDSTR,";",PIECE),":")="A":"T",1:$P($P(AGCDSTR,";",PIECE),":"))_U
K AGZERO,PIECE
Q AGCODES
UPPER(STR) ;EP - CHANGE LOWER TO UPPER
Q $TR(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
TYPE(TYPE) ;SET FIELDTYPE TO T(TEXT),N(UMERIC),I(NTEGER) OR D(ATE)
Q:TYPE["D" "D"
Q:TYPE["N" "N"
Q:TYPE["P" "I"
Q "F"
SPECIAL(STR) ;CHANGE SPECIAL CHARS TO NULL
Q $TR(STR,"'""!@#$%^&*():;<>?/\|,.`~[]{}-+=","")
;DELETE OBSOLETE FIELDS
DELOBSOL(CATPRIOR) ;
S CATEGORY=""
F S CATEGORY=$O(CATPRIOR(CATEGORY)) Q:CATEGORY="" D
.S PRIORITY=""
.F S PRIORITY=$O(CATPRIOR(CATEGORY,PRIORITY)) Q:PRIORITY="" D
..S INSPTR=""
..F S INSPTR=$O(CATPRIOR(CATEGORY,PRIORITY,INSPTR)) Q:INSPTR="" D
...S FILENO=""
...F S FILENO=$O(CATPRIOR(CATEGORY,PRIORITY,INSPTR,FILENO)) Q:FILENO="" D
....S FDAIENS=""
....F S FDAIENS=$O(CATPRIOR(CATEGORY,PRIORITY,INSPTR,FILENO,FDAIENS)) Q:FDAIENS="" D
.....S FIELD=""
.....F S FIELD=$O(CATPRIOR(CATEGORY,PRIORITY,INSPTR,FILENO,FDAIENS,FIELD)) Q:FIELD="" D
......D FIELD^DID(FILENO,FIELD,"","LABEL","AGGFIELD","AGGERR")
......I AGGFIELD("LABEL")["*" K CATPRIOR(CATEGORY,PRIORITY,INSPTR,FILENO,FDAIENS,FIELD)
Q
AGAPIS ;IHS/SD/TPF - PATIENT REGISTRATION ELIGIBLITY API CALL
+1 ;;7.1;PATIENT REGISTRATION;**2,12**;AUG 25, 2005;Build 1
+2 ;
+3 ;IHS/OIT/NKD AG*7.1*12 INSURER TYPE
+4 ;
+5 WRITE !,"DO NOT CALL FROM ROOT!"
+6 QUIT
+7 ;
+8 ;GENERAL LOGIC:
+9 ;
+10 ;USING THE "EFF" CROSS REFERENCE IN THE "CATEGORY PRIORITIZING" FILE
+11 ;#9000035 FIND ALL PRIORITIZED CATEGORIES FOR THE PATIENT DFN (AGGIEN)
+12 ;WHICH ARE EFFECTIVE (EFFECTIVE DATE OF PRIORITY (#.06) ) AS
+13 ;OF THE DATE OF SERVICE (AGGDOS).
+14 ;
+15 ;NEXT, ELIMINATE ANY ENTRIES IN THE ELIGIBILITY FILE WHICH ARE FOUND TO
+16 ;BE NON-ACTIVE GIVEN THE DATE OF SERVICE (AGGDOS). THE DATE OF SERVICE
+17 ;IS COMPARED TO THE 'BEGIN' AND ENDING DATES OF COVERAGE FOUND IN THE
+18 ;APPROPRIATE ELIGIBLITY FILE.
+19 ;
+20 ;IF THE ELIGIBILITY ENTRY IS FOUND TO BE ACTIVE THEN THE CATEGORY AND
+21 ;ELIGIBILITY DATA IS ADDED TO THE RETURNED ARRAY
+22 ;OR STRING IF AGGBMX=1.
+23 ;
+24 ;THE RETURNED ARRAY HAS THE FOLLOWING BASIC STRUCTURE:
+25 ;
+26 ; AGGXY(CATEGORY,PRIORITY,INSURER POINTER,File #, fda iens,
+27 ; Field#/Field Name, [Internal/External])=DATA
+28 ;
+29 ;THE SUBSCRIPT STRUCTURE BEYOND THE INSURER POINTER (THIRD SUBSCRIPT) IS
+30 ;IN THE FORM OF A STANDARD FDA ARRAY RETURNED BY THE FIELMAN DBS API
+31 ;$$GETS^DIQ() Data Retriever AND IS DEPENDENT UPON THE FLAGS PASSED VIA
+32 ;PARAMETER AGGFLAG. SEE "VA FILEMAN V. 22.0 PROGRAMMER MANUAL"
+33 ;PAGE 2-186 FOR DETAILS ON WHAT THE FLAGS MEAN. KEEP IN MIND THE
+34 ;RETURNED ARRAY'S STRUCTURE CHANGES DEPENDING ON THE FLAGS BEING PASSED.
+35 ;NOTE: THE 'INSURER POINTER' SUBSCRIPT FOR THE GUARANTOR WILL BE THE
+36 ;GLOBAL RFERENCE TO THE ACTUAL GUARANTOR
+37 ; E.G.
+38 ; AGGXY("T",1,"AUPNPAT(5571,0)","9000003.1","97,",".01","E")="GEGNUN,DELORES M"
+39 ;
+40 ;IN THE CASE ABOVE, THE GUARANTOR IS THE PATIENT. THE GUARANTOR
+41 ;AS OF THIS PATCH CAN BE A PATIENT, AN INSURER OR AN EMPLOYER
+42 ;
+43 ;IF AGGBMX=1 THEN THE BMXNet STRING IS RETURNED. IT'S FORMAT IS THE
+44 ;SAME AS THE BMXNet STRUCTURE FOR STATIC TABLES. SEE PAGES 8-9 OF THE
+45 ;"BMXNet ADO.NET Data Access and Connectivity Utilities for RPMS User
+46 ;Manual" FOR A DESCRIPTION OF THIS STRUCTURE.
+47 ;
+48 ;PARAMETERS:
+49 ;AGGXY = RETURNED DATA ARRAY OR STRING
+50 ;AGGIEN = PATIENT'S DFN. if null error message returned
+51 ;AGGDOS = DATE OF SERVICE
+52 ; If null, AGGDOS=DT
+53 ;
+54 ;AGGFLAG = STANDARD FLAGS FOR GETS^DIQ CALL
+55 ; "I" = INTERNAL
+56 ; "E" = EXTERNAL VALUES (DEFAULT)
+57 ; "N" = DON'T RETURN NULL VALUES
+58 ; "R" = RESOLVE FILE NUMBERS TO NAMES
+59 ;
+60 ; if null the default is "E"
+61 ;
+62 ;AGGCAT = A ^ DELIMITED STRING CONTAINING THE CATEGORIES REQUESTED
+63 ; 'M' FOR MEDICAL;
+64 ; 'D' FOR DENTAL;
+65 ; 'O' FOR OPTOMETRY;
+66 ; 'R' FOR PHARMACY;
+67 ; 'P' FOR MENTAL HEALTH;
+68 ; 'A' FOR AUTO ACCIDENT/TORT; This is the same
+69 ; as third party liability
+70 ; 'W' FOR WORKMAN'S COMP;
+71 ;
+72 ; E.G. ^M^A^W^
+73 ;
+74 ; WILL RETURN MEDICAL,AUTO ACCIDENT AND WORKMEN'S COM
+75 ; CATEGORIES.
+76 ; if null the default is ALL CATEGORIES
+77 ;
+78 ;AGGBMX = IF 1 THEN DATA IS RETURNED IN BMXNET FORMAT
+79 ; IF 0 THEN DATA IS RETURNED IN ARRAY FORMAT DESCRIBED ABOVE
+80 ; if null the default is 0
+81 ;
+82 ;IF NO EFFECTIVE SEQUENCE CATEGORIES ARE FOUND:
+83 ; 1) THE BMXNET CALLER WIL RECEIVE THE COLUMN SCHEMA WITH NO RECORDS
+84 ; E.G. AGGXY="T00004CATEGORY^N000030PRIORITY^N000030INSURER^
+85 ; N000030FILE_NUMBER^F000030FDA_IENS^F000050FIELD^
+86 ; F000080DATA^"
+87 ;
+88 ; 2) AGGXY WILL BE UNDEFINED FOR A NON BMXNET CALLER
+89 ; D GETELIG^AGAPIS(.LJF,10416,DT,"ER","",0)
GETELIG(AGGXY,AGGIEN,AGGDOS,AGGFLAG,AGGCAT,AGGBMX) ;PEP - API ENTRY FOR ACTIVE INSURANCE COVERAGE
+1 NEW PATIEN,RECORD,FLD,AGGDATA,AGGRET,AGGRETMP,CATPRIOR
+2 IF '$DATA(^AUPNPAT(AGGIEN))!'$DATA(^DPT(AGGIEN))
SET AGGXY="T00040ERROR"_$CHAR(30)_"Patient not in either PATIENT or VA PATIENT file"_$CHAR(30)_$CHAR(31)
QUIT
+3 IF $GET(AGGCAT)'=""
Begin DoDot:1
+4 IF $EXTRACT(AGGCAT)'=U
SET AGGCAT=U_AGGCAT
+5 IF $EXTRACT(AGGCAT,$LENGTH(AGGCAT))'=U
SET AGGCAT=AGGCAT_U
End DoDot:1
+6 IF $GET(AGGIEN)=""
IF $GET(AGGBMX)
SET AGGXY="T00040ERROR"_$CHAR(30)_"No patient IEN"_$CHAR(30)_$CHAR(31)
QUIT
+7 IF $GET(AGGIEN)=""
KILL AGGXY
QUIT
+8 IF $GET(AGGBMX)=""
SET AGGBMX=0
+9 IF $GET(AGGDOS)=""
SET AGGDOS=DT
+10 IF $GET(AGGCAT)'=""
SET AGGCAT=$$UPPER(AGGCAT)
+11 IF AGGFLAG'=""
SET AGGFLAG=$$UPPER(AGGFLAG)
+12 IF $GET(AGGCAT)=""
SET AGGCAT=$$GETCODES()
+13 IF $GET(AGGFLAG)=""
SET AGGFLAG="E"
+14 SET AGGRETMP=""
+15 ;GO THROUGH THE CATEGORIES AND GRAB ONLY THOSE SELECTED IN AGGCAT
+16 SET CAT=""
+17 FOR
SET CAT=$ORDER(^AUPNICP("EFF",AGGIEN,CAT))
IF CAT=""
QUIT
Begin DoDot:1
+18 IF AGGCAT'[(U_CAT_U)
QUIT
+19 SET EFFDT=$ORDER(^AUPNICP("EFF",AGGIEN,CAT,AGGDOS+.01),-1)
+20 IF EFFDT=""
QUIT
+21 SET RECORD=""
+22 FOR
SET RECORD=$ORDER(^AUPNICP("EFF",AGGIEN,CAT,EFFDT,RECORD))
IF RECORD=""
QUIT
Begin DoDot:2
+23 KILL AGGDATA,AGGERR
+24 ;GET DATA FROM 'CATEGORY PRIORITIZING' FILE
+25 DO GETS^DIQ(9000035,RECORD,"*","I","AGGDATA","AGGERR")
+26 IF $DATA(AGGERR)
QUIT
+27 MERGE AGGRETMP=AGGDATA
End DoDot:2
End DoDot:1
+28 ;GO GET INSURANCE ELIGIBILITY
+29 KILL CATPRIOR
+30 DO GETINS(.AGGRETMP,.CATPRIOR)
+31 ;DELETE OBSOLETE FIELDS MARKED WITH '*' IN NAME
DO DELOBSOL(.CATPRIOR)
+32 ;HERE WE SHOULD HAVE A LIST OF ALL ACTIVE SEQ. ELIGIBILITIES SORTED IN CATPRIOR
+33 IF 'AGGBMX
MERGE AGGXY=CATPRIOR
DO CLEAN
QUIT
+34 ;OTHERWISE SEND BACK A BMX RECORD SET
+35 DO BMXHDR(.HDR)
+36 DO BMXSET(.CATPRIOR,.AGGXY)
+37 SET AGGXY=HDR_$CHAR(30)_AGGXY_$CHAR(30)
+38 DO CLEAN
+39 QUIT
+40 ;GET ELIGIBLITY INFO AND SORT BY CATEGORY,PRIORITY AND INSURER
GETINS(AGGELIG,CATPRIOR) ;
+1 SET RECORD=""
+2 ;SORT THE CATEGORIZED ENTRIES BY CATEGORY AND PRIORITY
+3 FOR
SET RECORD=$ORDER(AGGELIG(9000035,RECORD))
IF RECORD=""
QUIT
Begin DoDot:1
+4 SET RECPTR=$GET(AGGELIG(9000035,RECORD,".15","I"))
+5 SET INSPTR=$GET(AGGELIG(9000035,RECORD,".03","I"))
+6 SET PRIORITY=$GET(AGGELIG(9000035,RECORD,".05","I"))
+7 SET CATEGORY=$GET(AGGELIG(9000035,RECORD,.04,"I"))
+8 SET COVTYPE=$GET(AGGELIG(9000035,RECORD,.07,"I"))
+9 SET CATPRIOR(CATEGORY,PRIORITY,INSPTR)=RECPTR_"|"_COVTYPE
End DoDot:1
+10 ;
+11 ;NOW GET THE ELIGIBILITY DATA
+12 SET CATEGORY=""
+13 FOR
SET CATEGORY=$ORDER(CATPRIOR(CATEGORY))
IF CATEGORY=""
QUIT
Begin DoDot:1
+14 SET PRIORITY=""
+15 FOR
SET PRIORITY=$ORDER(CATPRIOR(CATEGORY,PRIORITY))
IF PRIORITY=""
QUIT
Begin DoDot:2
+16 SET INSPTR=""
+17 SET INSPTR=$ORDER(CATPRIOR(CATEGORY,PRIORITY,INSPTR))
IF INSPTR=""
QUIT
Begin DoDot:3
+18 KILL AGGERR,AGGDATA
+19 ;GET INSURER TYPE FROM INSURER FILE
+20 IF $PIECE(CATPRIOR(CATEGORY,PRIORITY,INSPTR),"|",2)="G"
Begin DoDot:4
+21 SET INSTYPE="GUARANTOR"
End DoDot:4
+22 ;E S INSTYPE=$$GET1^DIQ(9999999.18,INSPTR,.21,"E","AGGINS","AGGERR")
+23 ;IHS/OIT/NKD AG*7.1*12
IF '$TEST
SET INSTYPE=$$INSTYP^AGUTL(INSPTR,1)
+24 SET RECPTR=$PIECE(CATPRIOR(CATEGORY,PRIORITY,INSPTR),"|")
+25 SET COVTYPE=$PIECE(CATPRIOR(CATEGORY,PRIORITY,INSPTR),"|",2)
+26 ;RAILROAD RETIRMENT A & B
IF INSPTR=1
IF (COVTYPE'="D")
DO GETRRAB^AGAPIS1(.CATPRIOR)
QUIT
+27 ;MEDICARE A & B
IF INSPTR=2
IF (COVTYPE'="D")
DO GETMCRAB^AGAPIS1(.CATPRIOR)
QUIT
+28 ;MEDICAID
IF INSPTR=3
DO GETMCD^AGAPIS1(.CATPRIOR)
QUIT
+29 ;RAILROAD RETIREMENT PART D
IF INSPTR=1
IF (COVTYPE="D")
DO GETRRD^AGAPIS1(.CATPRIOR)
QUIT
+30 ;MEDICARE PART D
IF INSPTR=2
IF (COVTYPE="D")
DO GETMCRD^AGAPIS1(.CATPRIOR)
QUIT
+31 ;MEDICARE PART D
IF INSTYPE="MCR PART D"
IF (COVTYPE="D")
DO GETMCRD^AGAPIS1(.CATPRIOR)
QUIT
+32 IF INSTYPE="GUARANTOR"
DO GETGUAR^AGAPIS1(.CATPRIOR)
QUIT
+33 IF INSTYPE="THIRD PARTY LIABILITY"
DO GETTPL^AGAPIS1(.CATPRIOR)
QUIT
+34 IF INSTYPE="WORKMEN'S COMP."
DO WCOMP^AGAPIS1(.CATPRIOR)
QUIT
+35 ;ALL OTHERS SHOULD BE PRIVATE INSURANCE
+36 DO GETPRVT^AGAPIS1(.CATPRIOR)
+37 KILL AGGDATA,AGGERR
End DoDot:3
End DoDot:2
End DoDot:1
+38 QUIT
CLEAN ;
+1 KILL AGCODES,AGGRET,AGGDATA,AGGFLAG,AGGFILE,FIELDTYP,AGGHDR,AGGZERO
+2 KILL RECORD,AGCODES,AGGRETMP,AGCDSTR,CAT,CATEGORY,COVTYPE,EFFDT,INSPTR,INSTYPE,POLHPTR
+3 KILL PRIORITY,RECPTR,TPRECPTR,SBRECPTR,FILENO,DATA,FIELDS,FDAIENS,AGGINS,AGGPOLH
+4 KILL X,Y,HDR,AGGFIELD
+5 QUIT
+6 ;CREATE BMXNET COLUMN HEADER FOR BMX RECORD SET
BMXHDR(HDR) ;
+1 SET HDR="T00004CATEGORY"_U
+2 SET HDR=HDR_"N000030PRIORITY"_U
+3 SET HDR=HDR_"N000030INSURER"_U
+4 SET HDR=HDR_"N000030FILE_NUMBER"_U
+5 SET HDR=HDR_"F000030FDA_IENS"_U
+6 SET HDR=HDR_"F000050FIELD"_U
+7 SET HDR=HDR_"F000080DATA"
+8 QUIT HDR
+9 ;CREATE BMXNET RECORD SET TO SEND BACK TO CLIENT
BMXSET(CATPRIOR,AGGXY) ;
+1 NEW AGGRET
+2 SET AGGRET=""
+3 SET CATEGORY=""
+4 FOR
SET CATEGORY=$ORDER(CATPRIOR(CATEGORY))
IF CATEGORY=""
QUIT
Begin DoDot:1
+5 SET PRIORITY=""
+6 FOR
SET PRIORITY=$ORDER(CATPRIOR(CATEGORY,PRIORITY))
IF PRIORITY=""
QUIT
Begin DoDot:2
+7 SET INSPTR=""
+8 FOR
SET INSPTR=$ORDER(CATPRIOR(CATEGORY,PRIORITY,INSPTR))
IF INSPTR=""
QUIT
Begin DoDot:3
+9 SET FILENO=""
+10 FOR
SET FILENO=$ORDER(CATPRIOR(CATEGORY,PRIORITY,INSPTR,FILENO))
IF FILENO=""
QUIT
Begin DoDot:4
+11 SET FDAIENS=""
+12 FOR
SET FDAIENS=$ORDER(CATPRIOR(CATEGORY,PRIORITY,INSPTR,FILENO,FDAIENS))
IF FDAIENS=""
QUIT
Begin DoDot:5
+13 SET FIELD=""
+14 FOR
SET FIELD=$ORDER(CATPRIOR(CATEGORY,PRIORITY,INSPTR,FILENO,FDAIENS,FIELD))
IF FIELD=""
QUIT
Begin DoDot:6
+15 SET DATA=$GET(CATPRIOR(CATEGORY,PRIORITY,INSPTR,FILENO,FDAIENS,FIELD))
+16 IF DATA=""
SET DATA=$GET(CATPRIOR(CATEGORY,PRIORITY,INSPTR,FILENO,FDAIENS,FIELD,"I"))
+17 IF DATA=""
SET DATA=$GET(CATPRIOR(CATEGORY,PRIORITY,INSPTR,FILENO,FDAIENS,FIELD,"E"))
+18 SET AGGRET=AGGRET_CATEGORY_U_PRIORITY_U_INSPTR_U_FILENO_U_FDAIENS_U_FIELD_U_DATA_$CHAR(30)
+19 ;W !,AGGRET
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+20 MERGE AGGXY=AGGRET
+21 QUIT
GETCODES() ;
+1 SET AGZERO=$GET(^DD(9000035,.04,0))
SET AGCDSTR=$PIECE(AGZERO,U,3)
+2 SET AGCODES=U
+3 FOR PIECE=1:1
IF $PIECE($PIECE(AGCDSTR,";",PIECE),"
QUIT
SET AGCODES=AGCODES_$SELECT($PIECE($PIECE(AGCDSTR,";",PIECE),":")="A":"T",1:$PIECE($PIECE(AGCDSTR,";",PIECE),":"))_U
+4 KILL AGZERO,PIECE
+5 QUIT AGCODES
UPPER(STR) ;EP - CHANGE LOWER TO UPPER
+1 QUIT $TRANSLATE(STR,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
TYPE(TYPE) ;SET FIELDTYPE TO T(TEXT),N(UMERIC),I(NTEGER) OR D(ATE)
+1 IF TYPE["D"
QUIT "D"
+2 IF TYPE["N"
QUIT "N"
+3 IF TYPE["P"
QUIT "I"
+4 QUIT "F"
SPECIAL(STR) ;CHANGE SPECIAL CHARS TO NULL
+1 QUIT $TRANSLATE(STR,"'""!@#$%^&*():;<>?/\|,.`~[]{}-+=","")
+2 ;DELETE OBSOLETE FIELDS
DELOBSOL(CATPRIOR) ;
+1 SET CATEGORY=""
+2 FOR
SET CATEGORY=$ORDER(CATPRIOR(CATEGORY))
IF CATEGORY=""
QUIT
Begin DoDot:1
+3 SET PRIORITY=""
+4 FOR
SET PRIORITY=$ORDER(CATPRIOR(CATEGORY,PRIORITY))
IF PRIORITY=""
QUIT
Begin DoDot:2
+5 SET INSPTR=""
+6 FOR
SET INSPTR=$ORDER(CATPRIOR(CATEGORY,PRIORITY,INSPTR))
IF INSPTR=""
QUIT
Begin DoDot:3
+7 SET FILENO=""
+8 FOR
SET FILENO=$ORDER(CATPRIOR(CATEGORY,PRIORITY,INSPTR,FILENO))
IF FILENO=""
QUIT
Begin DoDot:4
+9 SET FDAIENS=""
+10 FOR
SET FDAIENS=$ORDER(CATPRIOR(CATEGORY,PRIORITY,INSPTR,FILENO,FDAIENS))
IF FDAIENS=""
QUIT
Begin DoDot:5
+11 SET FIELD=""
+12 FOR
SET FIELD=$ORDER(CATPRIOR(CATEGORY,PRIORITY,INSPTR,FILENO,FDAIENS,FIELD))
IF FIELD=""
QUIT
Begin DoDot:6
+13 DO FIELD^DID(FILENO,FIELD,"","LABEL","AGGFIELD","AGGERR")
+14 IF AGGFIELD("LABEL")["*"
KILL CATPRIOR(CATEGORY,PRIORITY,INSPTR,FILENO,FDAIENS,FIELD)
End DoDot:6
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+15 QUIT
