EASEZI1 ;ALB/jap - Database Inquiry & Record Finder for 1010EZ Processing ;10/12/00 13:08
;;1.0;ENROLLMENT APPLICATION SYSTEM;**57,70**;Mar 15, 2001;Build 26
;continuation of EASEZI, split by patch 57 due to Max size limit
;
RESET ;
;set link in file #712 record
N FDA,ERR
S FDA(712,EASAPP_",",3.4)=DFN
I NEW D
. S FDA(712,EASAPP_",",3.5)=NEW
D FILE^DIE("","FDA","ERR")
;
W !,"One moment please...",!
S EASDFN=DFN
;setup tmp array for data mapping
D LOCAL711^EASEZU2
I '$G(EASVRSN) S EASVRSN=$$VERSION^EASEZU4(EASAPP)
;if applicant is new to database, user accept/not accept of data elements is constrained;
;if applicant is new to VistA, mark all data elements 'accepted';
I NEW S N=0 F S N=$O(^EAS(712,EASAPP,10,N)) Q:'N I $G(^EAS(712,EASAPP,10,N,1))'="" D
. S ACCEPT="",FLD="",SUBFILE="",FILE=""
. S KEYIEN=$P(^EAS(712,EASAPP,10,N,0),U,1)
. I KEYIEN S X=$G(^TMP("EZDATA",$J,KEYIEN)),FILE=$P(X,U,1),SUBFILE=$P(X,U,2),FLD=$P(X,U,3),DATAKEY=$P(X,U,4),SECT=$P(DATAKEY,";",1)
. I FLD S ACCEPT=1
. I 'FLD S ACCEPT=-1
. I (FILE=355.33)!(FILE>408) S ACCEPT=2
. I FILE=2,SUBFILE=2,((FLD=.01)!(FLD=.03)!(FLD=.09)!(FLD=.531)) S ACCEPT=-1
. I ((SUBFILE=2.01)!(SUBFILE=2.101)) S ACCEPT=-1
. I (EASVRSN>5.99),((SECT="IIC")!(SECT="IIE")) D
. . S QUES=$P(DATAKEY,";",2)
. . ;EAS*1.0*70 -- added up-arrows on next two lines
. . I SECT="IIC","^1.6^2.3^3.3^"[("^"_QUES_"^") S ACCEPT=-1 Q
. . I SECT="IIE","^1.3^2.3^3.3^"[("^"_QUES_"^") S ACCEPT=-1
. S $P(^EAS(712,EASAPP,10,N,0),U,3)=ACCEPT
;for applicants matched to existing patients check for
; verified eligibility and appt request on 1010 app
I 'NEW D
. K ARRAY
. S DA=EASDFN,DIC="^DPT(",DR=".3611;.3613;1010.159;1010.1511"
. S DIQ(0)="I",DIQ="ARRAY"
. D EN^DIQ1
. I ARRAY(2,EASDFN,.3611,"I")="V",ARRAY(2,EASDFN,.3613,"I")="H" S ELIGVER=1
. I ARRAY(2,EASDFN,1010.159,"I")'="",ARRAY(2,EASDFN,1010.1511,"I")'="" S APPTVER=1
;correlate #712 data with mapping array
S N=0 F S N=$O(^EAS(712,EASAPP,10,N)) Q:'N S X=^(N,0) D
. ;don't set array node if no 1010EZ data
. S EZDATA=$P($G(^EAS(712,EASAPP,10,N,1)),U,1)
. Q:EZDATA=""
. S IEN=$P(X,U,1),MULTIPLE=$P(X,U,2),ACCEPT=$P(X,U,3)
. S ^TMP("EZDATA",$J,IEN,MULTIPLE,1)=EZDATA_U_ACCEPT_U_N
;
;if applicant new to VistA, stop here;
I NEW S EASEZNEW=1
Q:$G(EASEZNEW)
;if matched to existing patient, get all iens needed
W !,"Preparing for data comparison to VistA Patient database...",!
K ALIAS,DISPOS,ENROLL,INCREL,RACE,ETHNC
D I201^EASEZI(EASDFN,.ALIAS) W "."
I $D(ALIAS)>1 D C201^EASEZC1
D I2101^EASEZI(EASDFN,.DISPOS) W "."
I $D(DISPOS)>1 D C2101^EASEZC1
;finish getting the rest of file #2 data needed for comparison
D C2^EASEZC1
D I2711^EASEZI(EASDFN,.ENROLL) W "."
I $D(ENROLL)>1 D C2711^EASEZC1
D I408^EASEZI(EASDFN,EASAPP,.INCREL) W "."
I $D(INCREL)>1 D C408^EASEZC1
D I202^EASEZI(EASDFN,.RACE) W "."
I $D(RACE)>1 D C202^EASEZC3
D I206^EASEZI(EASDFN,.ETHNC) W "."
I $D(ETHNC)>1 D C206^EASEZC3
;set file #355.33 data to 'always accept';
;set unmatched data for files #408.12, #408.13, #408.21, #408.22 to 'always accept';
S N=0 F S N=$O(^EAS(712,EASAPP,10,N)) Q:'N S X=^(N,0) D
. S KEYIEN=$P(X,U,1),MULTIPLE=$P(X,U,2)
. I KEYIEN S X=$G(^TMP("EZDATA",$J,KEYIEN)),FILE=$P(X,U,1),SUBFILE=$P(X,U,2),FLD=$P(X,U,3),DATAKEY=$P(X,U,4),SECT=$P(DATAKEY,";",1)
. S ACCEPT=""
. I 'FLD S ACCEPT=-1
. I FILE=2,SUBFILE=2,((FLD=.01)!(FLD=.03)!(FLD=.09)!(FLD=.531)) S ACCEPT=-1
. ;set certain eligibility related data elements to 'never accept' if eligibility verified
. I FILE=2,FLD=.313,$G(ARRAY(2,EASDFN,.3611,"I"))="V" S ACCEPT=-1
. I FILE=2,$G(ELIGVER),((FLD=.301)!(FLD=.302)!(FLD=.36235)) S ACCEPT=-1
. ;set appt requested element to 'never accept' if already exist
. I FILE=2,$G(APPTVER),FLD=1010.159 S ACCEPT=-1
. ;EAS*1.0*70 -- accept Country
. I FILE=2,(FLD=.1173) S ACCEPT=1
. I FILE=355.33 S ACCEPT=2
. I FILE>408 S ACCEPT=2
. I (EASVRSN>5.99),((SECT="IIC")!(SECT="IIE")) D
. . S QUES=$P(DATAKEY,";",2)
. . ;EAS*1.0*70 -- added the up-arrows on next two lines
. . I SECT="IIC","^1.6^2.3^3.3^"[("^"_QUES_"^") S ACCEPT=-1 Q
. . I SECT="IIE","^1.3^2.3^3.3^"[("^"_QUES_"^") S ACCEPT=-1
. S $P(^EAS(712,EASAPP,10,N,0),U,3)=ACCEPT
. S $P(^TMP("EZDATA",$J,KEYIEN,MULTIPLE,1),U,2)=ACCEPT
K ALIAS,DISPOS,ENROLL,INCREL
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HEASEZI1 4399 printed Apr 09, 2024@21:00:45 Page 2
EASEZI1 ;ALB/jap - Database Inquiry & Record Finder for 1010EZ Processing ;10/12/00 13:08
+1 ;;1.0;ENROLLMENT APPLICATION SYSTEM;**57,70**;Mar 15, 2001;Build 26
+2 ;continuation of EASEZI, split by patch 57 due to Max size limit
+3 ;
RESET ;
+1 ;set link in file #712 record
+2 NEW FDA,ERR
+3 SET FDA(712,EASAPP_",",3.4)=DFN
+4 IF NEW
Begin DoDot:1
+5 SET FDA(712,EASAPP_",",3.5)=NEW
End DoDot:1
+6 DO FILE^DIE("","FDA","ERR")
+7 ;
+8 WRITE !,"One moment please...",!
+9 SET EASDFN=DFN
+10 ;setup tmp array for data mapping
+11 DO LOCAL711^EASEZU2
+12 IF '$GET(EASVRSN)
SET EASVRSN=$$VERSION^EASEZU4(EASAPP)
+13 ;if applicant is new to database, user accept/not accept of data elements is constrained;
+14 ;if applicant is new to VistA, mark all data elements 'accepted';
+15 IF NEW
SET N=0
FOR
SET N=$ORDER(^EAS(712,EASAPP,10,N))
if 'N
QUIT
IF $GET(^EAS(712,EASAPP,10,N,1))'=""
Begin DoDot:1
+16 SET ACCEPT=""
SET FLD=""
SET SUBFILE=""
SET FILE=""
+17 SET KEYIEN=$PIECE(^EAS(712,EASAPP,10,N,0),U,1)
+18 IF KEYIEN
SET X=$GET(^TMP("EZDATA",$JOB,KEYIEN))
SET FILE=$PIECE(X,U,1)
SET SUBFILE=$PIECE(X,U,2)
SET FLD=$PIECE(X,U,3)
SET DATAKEY=$PIECE(X,U,4)
SET SECT=$PIECE(DATAKEY,";",1)
+19 IF FLD
SET ACCEPT=1
+20 IF 'FLD
SET ACCEPT=-1
+21 IF (FILE=355.33)!(FILE>408)
SET ACCEPT=2
+22 IF FILE=2
IF SUBFILE=2
IF ((FLD=.01)!(FLD=.03)!(FLD=.09)!(FLD=.531))
SET ACCEPT=-1
+23 IF ((SUBFILE=2.01)!(SUBFILE=2.101))
SET ACCEPT=-1
+24 IF (EASVRSN>5.99)
IF ((SECT="IIC")!(SECT="IIE"))
Begin DoDot:2
+25 SET QUES=$PIECE(DATAKEY,";",2)
+26 ;EAS*1.0*70 -- added up-arrows on next two lines
+27 IF SECT="IIC"
IF "^1.6^2.3^3.3^"[("^"_QUES_"^")
SET ACCEPT=-1
QUIT
+28 IF SECT="IIE"
IF "^1.3^2.3^3.3^"[("^"_QUES_"^")
SET ACCEPT=-1
End DoDot:2
+29 SET $PIECE(^EAS(712,EASAPP,10,N,0),U,3)=ACCEPT
End DoDot:1
+30 ;for applicants matched to existing patients check for
+31 ; verified eligibility and appt request on 1010 app
+32 IF 'NEW
Begin DoDot:1
+33 KILL ARRAY
+34 SET DA=EASDFN
SET DIC="^DPT("
SET DR=".3611;.3613;1010.159;1010.1511"
+35 SET DIQ(0)="I"
SET DIQ="ARRAY"
+36 DO EN^DIQ1
+37 IF ARRAY(2,EASDFN,.3611,"I")="V"
IF ARRAY(2,EASDFN,.3613,"I")="H"
SET ELIGVER=1
+38 IF ARRAY(2,EASDFN,1010.159,"I")'=""
IF ARRAY(2,EASDFN,1010.1511,"I")'=""
SET APPTVER=1
End DoDot:1
+39 ;correlate #712 data with mapping array
+40 SET N=0
FOR
SET N=$ORDER(^EAS(712,EASAPP,10,N))
if 'N
QUIT
SET X=^(N,0)
Begin DoDot:1
+41 ;don't set array node if no 1010EZ data
+42 SET EZDATA=$PIECE($GET(^EAS(712,EASAPP,10,N,1)),U,1)
+43 if EZDATA=""
QUIT
+44 SET IEN=$PIECE(X,U,1)
SET MULTIPLE=$PIECE(X,U,2)
SET ACCEPT=$PIECE(X,U,3)
+45 SET ^TMP("EZDATA",$JOB,IEN,MULTIPLE,1)=EZDATA_U_ACCEPT_U_N
End DoDot:1
+46 ;
+47 ;if applicant new to VistA, stop here;
+48 IF NEW
SET EASEZNEW=1
+49 if $GET(EASEZNEW)
QUIT
+50 ;if matched to existing patient, get all iens needed
+51 WRITE !,"Preparing for data comparison to VistA Patient database...",!
+52 KILL ALIAS,DISPOS,ENROLL,INCREL,RACE,ETHNC
+53 DO I201^EASEZI(EASDFN,.ALIAS)
WRITE "."
+54 IF $DATA(ALIAS)>1
DO C201^EASEZC1
+55 DO I2101^EASEZI(EASDFN,.DISPOS)
WRITE "."
+56 IF $DATA(DISPOS)>1
DO C2101^EASEZC1
+57 ;finish getting the rest of file #2 data needed for comparison
+58 DO C2^EASEZC1
+59 DO I2711^EASEZI(EASDFN,.ENROLL)
WRITE "."
+60 IF $DATA(ENROLL)>1
DO C2711^EASEZC1
+61 DO I408^EASEZI(EASDFN,EASAPP,.INCREL)
WRITE "."
+62 IF $DATA(INCREL)>1
DO C408^EASEZC1
+63 DO I202^EASEZI(EASDFN,.RACE)
WRITE "."
+64 IF $DATA(RACE)>1
DO C202^EASEZC3
+65 DO I206^EASEZI(EASDFN,.ETHNC)
WRITE "."
+66 IF $DATA(ETHNC)>1
DO C206^EASEZC3
+67 ;set file #355.33 data to 'always accept';
+68 ;set unmatched data for files #408.12, #408.13, #408.21, #408.22 to 'always accept';
+69 SET N=0
FOR
SET N=$ORDER(^EAS(712,EASAPP,10,N))
if 'N
QUIT
SET X=^(N,0)
Begin DoDot:1
+70 SET KEYIEN=$PIECE(X,U,1)
SET MULTIPLE=$PIECE(X,U,2)
+71 IF KEYIEN
SET X=$GET(^TMP("EZDATA",$JOB,KEYIEN))
SET FILE=$PIECE(X,U,1)
SET SUBFILE=$PIECE(X,U,2)
SET FLD=$PIECE(X,U,3)
SET DATAKEY=$PIECE(X,U,4)
SET SECT=$PIECE(DATAKEY,";",1)
+72 SET ACCEPT=""
+73 IF 'FLD
SET ACCEPT=-1
+74 IF FILE=2
IF SUBFILE=2
IF ((FLD=.01)!(FLD=.03)!(FLD=.09)!(FLD=.531))
SET ACCEPT=-1
+75 ;set certain eligibility related data elements to 'never accept' if eligibility verified
+76 IF FILE=2
IF FLD=.313
IF $GET(ARRAY(2,EASDFN,.3611,"I"))="V"
SET ACCEPT=-1
+77 IF FILE=2
IF $GET(ELIGVER)
IF ((FLD=.301)!(FLD=.302)!(FLD=.36235))
SET ACCEPT=-1
+78 ;set appt requested element to 'never accept' if already exist
+79 IF FILE=2
IF $GET(APPTVER)
IF FLD=1010.159
SET ACCEPT=-1
+80 ;EAS*1.0*70 -- accept Country
+81 IF FILE=2
IF (FLD=.1173)
SET ACCEPT=1
+82 IF FILE=355.33
SET ACCEPT=2
+83 IF FILE>408
SET ACCEPT=2
+84 IF (EASVRSN>5.99)
IF ((SECT="IIC")!(SECT="IIE"))
Begin DoDot:2
+85 SET QUES=$PIECE(DATAKEY,";",2)
+86 ;EAS*1.0*70 -- added the up-arrows on next two lines
+87 IF SECT="IIC"
IF "^1.6^2.3^3.3^"[("^"_QUES_"^")
SET ACCEPT=-1
QUIT
+88 IF SECT="IIE"
IF "^1.3^2.3^3.3^"[("^"_QUES_"^")
SET ACCEPT=-1
End DoDot:2
+89 SET $PIECE(^EAS(712,EASAPP,10,N,0),U,3)=ACCEPT
+90 SET $PIECE(^TMP("EZDATA",$JOB,KEYIEN,MULTIPLE,1),U,2)=ACCEPT
End DoDot:1
+91 KILL ALIAS,DISPOS,ENROLL,INCREL
+92 QUIT
+93 ;
