EASEZI ;ALB/jap - Database Inquiry & Record Finder for 1010EZ Processing ;10/12/00 13:08
;;1.0;ENROLLMENT APPLICATION SYSTEM;**1,9,44,51,57,70,81,100**;Mar 15, 2001;Build 6
;
DFN(EASAPP,EASDFN) ;match or add 1010EZ applicant to Patient file #2
;
;input
; EASAPP = application ien in file #712
;output
; EASDFN = valid ien in file #2; passed by reference
; OR -1 if no patient match made;
; note: this may be an existing patient or one newly created by user action
;
;This entry point it used only for initial match of Applicant with Patient database.
;
N DFN,DGNEWPF,DGRPTOUT,EZDATA,KEY,NAME,SSN,DOB,SEX,KEYIEN,ACCEPT,ARRAY,RECD
N VETTYPE,NEW,TSSN,REM,N,X,DA,DR,DIE,DIC,DIQ,ALREADY,OUT,FILE,SUBFILE,FLD,ELIGVER,SVCVER,APPTVER
Q:'EASAPP
;do not proceed if link to file #2 already established
S EASDFN=$P($G(^EAS(712,EASAPP,0)),U,10) Q:EASDFN
D FULL^VALM1 W @IOF
S EASEZNEW="",ELIGVER=0,SVCVER=0,APPTVER=0
S KEY=$$KEY711^EASEZU1("APPLICANT SEX")
S SEX=$P($$DATA712^EASEZU1(EASAPP,KEY),U,1),SEX=$S(SEX="M":"Male",SEX="F":"Female",1:"")
S DIQ="ARRAY",DIQ(0)="E",DA=EASAPP,DR="1;2;3;3.3",DIC=712 D EN^DIQ1
S NAME=$G(ARRAY(712,EASAPP,1,"E"))
S SSN=$P($G(ARRAY(712,EASAPP,2,"E")),"&",1)
S DOB=$P($G(ARRAY(712,EASAPP,2,"E")),"&",2)
S RECD=$G(ARRAY(712,EASAPP,3,"E"))
S VETTYPE=$G(ARRAY(712,EASAPP,3.3,"E"))
W !,"Applicant Data",?24,"Application #: ",EASAPP,?48,"Received: ",RECD,!
W !,"Name: ",NAME
W !,"SSN: ",SSN,?24,"DOB: ",DOB,?48,"Sex: ",SEX
W !,"Veteran Type: ",VETTYPE
W !!,"Enter Applicant data as prompted --"
;
;Get Patient file (#2) IEN - DFN
;EAS*1*81 - changes made to allow adding new patient with same name
;as an existing patient
N EASANS,Y S EASANS=0
N DIR,DIRUT
S DIR(0)="YAO"
S DIR("?")="Enter 'Yes' if this patient is the one you want to select."
S DIR("A")="IS THIS THE CORRECT PATIENT? "
S DIR("B")="YES"
F Q:EASANS D K DIR
. D GETPAT^DGRPTU("",1,.DFN,.DGNEWPF) I DFN>0,($G(DGNEWPF)=1) S EASANS=1 Q
. I DFN'>0 S EASANS=1 Q
. I DFN>0,($G(DGNEWPF)'=1) D
. . D ^DIR
. . I $D(DIRUT) Q
. . I Y(0)["Y" S EASANS=1 Q
. . I Y(0)["N" K DFN
. . I $G(DFN)'>0 D
. . W !!?5,"If there are already one or more patients with the same name,",!?5,"re-enter the name in double quotes, for example, ""DOE,JOHN""."
Q:($G(DFN)'>0)
;if DGNEWPF=1 then applicant has just been added to file #2 as new patient
S NEW=""
I DGNEWPF D
. S NEW=1
. ;add a remark to file #2 record to help keep track of new patients added by 1010EZ
. S REM="NEW PT. FROM ELECTRONIC 10-10EZ -- IN PROCESS"
. S DA=DFN,DIE="^DPT(",DR=".091///^S X=REM"
. D ^DIE
;if seems to be not new, check remark field just to make sure
I NEW="" D
. S REM="NEW PT. FROM ELECTRONIC 10-10EZ -- IN PROCESS"
. I $P(^DPT(DFN,0),U,10)=REM S NEW=1
;MPI Query
S X="MPIFAPI" X ^%ZOSF("TEST") D
. Q:'$T
. K MPIFRTN
. D MPIQ^MPIFAPI(DFN)
. K MPIFRTN,MPIQRYNM
;check for an in-process application already linked to this DFN
S OUT=0,ALREADY=0 F S ALREADY=$O(^EAS(712,"AC",DFN,ALREADY)) Q:'ALREADY D Q:OUT
. S FILDATE=$P($G(^EAS(712,ALREADY,2)),U,5)
. S CLSDATE=$P($G(^EAS(712,ALREADY,2)),U,9)
. I 'FILDATE,'CLSDATE S OUT=1 D
. . W !!?3,"Sorry... cannot link to selected Patient."
. . W !?3,"Application #"_ALREADY_" is already linked to this Patient,"
. . W !?3,"and is still in-process."
. . D PAUSE^VALM1 K FILDATE,CLSDATE
Q:OUT
D RESET^EASEZI1
Q
;
I201(EASDFN,EASARRAY) ;retrieve ien(s) in subfile #2.01
;input EASDFN = ien to #2
;output EASARRAY = ien(s) to #2.01
; each array element = EASDFN;subfile_ien
;
N N,IEN
S IEN=0,N=0 F S IEN=$O(^DPT(EASDFN,.01,IEN)) Q:'IEN S N=N+1,EASARRAY(N)=EASDFN_";"_IEN
Q
;
I202(EASDFN,EASARRAY) ;retrieve ien(s) in subfile #2.02
;input EASDFN = ien to #2
;output EASARRAY = ien(s) to #2.01
; each array element = EASDFN;subfile_ien
;
N N,IEN
S IEN=0,N=0 F S IEN=$O(^DPT(EASDFN,.02,IEN)) Q:'IEN S N=N+1,EASARRAY(N)=EASDFN_";"_IEN
Q
;
I206(EASDFN,EASARRAY) ;retrieve ien(s) in subfile #2.06
;input EASDFN = ien to #2
;output EASARRAY = ien(s) to #2.01
; each array element = EASDFN;subfile_ien
;
N N,IEN
S IEN=0,N=0 F S IEN=$O(^DPT(EASDFN,.06,IEN)) Q:'IEN S N=N+1,EASARRAY(N)=EASDFN_";"_IEN
Q
;
I2101(EASDFN,EASARRAY) ;retrieve ien to subfile #2.101
;input EASDFN = ien to #2
;output EASARRAY = most recent ien in #2.101;
; array element = EASDFN;subfile_ien
;
N N,IEN,ARR,LAST,EASQUIT,EASICN
S EASQUIT=0
S IEN=0,N=0 F S IEN=$O(^DPT(EASDFN,"DIS",IEN)) Q:'IEN!EASQUIT D
. ;S RDATE=$P(^DPT(EASDFN,"DIS",IEN,0),U,1),ARR(RDATE)=IEN
. S RDATE=$P($G(^DPT(EASDFN,"DIS",IEN,0)),U,1) I RDATE]"" S ARR(RDATE)=IEN
. I RDATE']"" D
.. K XQA,XQAID,XQAMSG
.. S EASICN=$$GETICN^MPIF001(EASDFN) I EASICN]"" S EASICN=$P(EASICN,"V",1)
.. S XQA(DUZ)=""
.. S XQAID="EAS"
.. S XQAMSG="No disposition for "_$P(^DPT(EASDFN,0),"^",1)_" ICN: "_EASICN_" Re-register patient."
.. ;S $P(XQADATA,"^",1)="NAME : "_$P(^DPT(EASDFN,0),"^",1) ;PATIENT NAME
.. D SETUP^XQALERT
..; S EASQUIT=1 K ^DPT(EASDFN,"DIS",IEN),^DPT("ADA",1,EASDFN),ARR
.. S EASQUIT=1 D
... K ARR,DA,DA(1),DIK,EASNODE,EASDT
... S DA=IEN,DA(1)=EASDFN,DIK="^DPT("_EASDFN_",""DIS""," D ^DIK K DIK,DA
... I $D(^DPT("ADA",1,EASDFN)) S EASDT=$O(^DPT("ADA",1,EASDFN,0)),EASNODE="^DPT(""ADA"""_",1,"_EASDFN_","_EASDT_")" K @EASNODE
... Q
.. I '$D(IO("Q")) D
... W !!,"No disposition for "_$P(^DPT(EASDFN,0),"^",1)_" ICN: "_EASICN
... W !,"A blank 1010EZ may print. Please re-register the patient and reprint the 1010EZ."
... H 6
..; D ENQUIT^EASEZPF ; KILLS ALL OF THE ^TMP("EZ" VARIABLES FOR PRINTING1010EZ.
..S EASARRAY(1)="NO DISPOSITION" Q
I $D(ARR) D
. S LAST=$O(ARR(999999999),-1),IEN=ARR(LAST)
. S EASARRAY(1)=EASDFN_";"_IEN
Q
;
I2711(EASDFN,EASARRAY) ;retrieve ien to file #27.11
;input EASDFN = ien to #2
;output EASARRAY = current enrollment ien in #27.11;
; array element = ien
N CUR
S CUR=$$FINDCUR^DGENA(+EASDFN)
S EASARRAY(1)=CUR
Q
;
I408(EASDFN,EASAPP,EASARRAY) ;retrieve ien(s) to files #408.12,#408.13,#408.21,#408.22
;
;input EASDFN = ien to #2
; EASAPP = ien to #712
;output EASARRAY = ien(s) to files; passed by reference
; array(408,"V",1) = ien_#408.12^ien_#408.13^ien_#408.21^ien#408.22 ;veteran data
; array(408,"S",1) = ien_#408.12^ien_#408.13^ien_#408.21^ien#408.22 ;spouse data
; array(408,"C",multiple) = ien_#408.12^ien_#408.13^ien_#408.21^ien#408.22 ;child data
; where ien_#408.13 = ien;global_root
;
N CURINCYR,X,Y,DIC,DA,DR,DIQ,EAS,DEP,REL,IX,JX,KX,I13,SUB1,SUB2,INCYR,PT
;
Q:'EASDFN
S Y=$P($G(^EAS(712,EASAPP,0)),U,6) I Y="" S Y=DT
S %F=5,X=$$FMTE^XLFDT(Y,%F),X=+$P(X,"/",3)-1,%DT="P" D ^%DT S CURINCYR=Y
;find all associated 408 records, even if no actual income test
; get #408.12, #408.13, #408.21, #408.22 iens
K EAS S DEP=0
S IX=0 F S IX=$O(^DGPR(408.12,"B",EASDFN,IX)) Q:'IX D
. S DIC=408.12,DA=IX,DIQ="EAS",DIQ(0)="I",DR=".02;.03" D EN^DIQ1
. S REL=$G(EAS(408.12,IX,.02,"I")),I13=$G(EAS(408.12,IX,.03,"I"))
. S (SUB1,SUB2)="" S:REL=1 SUB1="V",SUB2=1 S:REL=2 SUB1="S",SUB2=1 S:REL>2 SUB1="C",DEP=DEP+1,SUB2=DEP
. I SUB1]"" S EASARRAY(408,SUB1,SUB2)=IX_U_I13 D
. . S JX=$O(^DGMT(408.21,"C",IX,""),-1)
. . I JX D
. . . S DIC=408.21,DA=JX,DIQ="EAS",DIQ(0)="I",DR=".01;.02" D EN^DIQ1
. . . S INCYR=$G(EAS(408.21,JX,.01,"I")),PT=$G(EAS(408.21,JX,.02,"I"))
. . . Q:PT'=IX
. . . Q:(INCYR<CURINCYR)
. . . S KX=$O(^DGMT(408.22,"AIND",JX,0))
. . . S EASARRAY(408,SUB1,SUB2)=EASARRAY(408,SUB1,SUB2)_U_JX_U_KX
Q
;
I1275(IEN) ;get the active subrecord from subfile #408.1275
;input IEN = internal record number to file #408.12
;output SUBIEN = internal record number for active subrecord,
; or -1 if invalid
N B,ACT,SUBIEN
I 'IEN Q -1
S SUBIEN=-1
S B=0 F S B=$O(^DGPR(408.12,IEN,"E",B)) Q:'B D
. S ACT=$P(^DGPR(408.12,IEN,"E",B,0),U,2)
. I ACT S SUBIEN=B
Q SUBIEN
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HEASEZI 8179 printed Dec 13, 2024@01:54:35 Page 2
EASEZI ;ALB/jap - Database Inquiry & Record Finder for 1010EZ Processing ;10/12/00 13:08
+1 ;;1.0;ENROLLMENT APPLICATION SYSTEM;**1,9,44,51,57,70,81,100**;Mar 15, 2001;Build 6
+2 ;
DFN(EASAPP,EASDFN) ;match or add 1010EZ applicant to Patient file #2
+1 ;
+2 ;input
+3 ; EASAPP = application ien in file #712
+4 ;output
+5 ; EASDFN = valid ien in file #2; passed by reference
+6 ; OR -1 if no patient match made;
+7 ; note: this may be an existing patient or one newly created by user action
+8 ;
+9 ;This entry point it used only for initial match of Applicant with Patient database.
+10 ;
+11 NEW DFN,DGNEWPF,DGRPTOUT,EZDATA,KEY,NAME,SSN,DOB,SEX,KEYIEN,ACCEPT,ARRAY,RECD
+12 NEW VETTYPE,NEW,TSSN,REM,N,X,DA,DR,DIE,DIC,DIQ,ALREADY,OUT,FILE,SUBFILE,FLD,ELIGVER,SVCVER,APPTVER
+13 if 'EASAPP
QUIT
+14 ;do not proceed if link to file #2 already established
+15 SET EASDFN=$PIECE($GET(^EAS(712,EASAPP,0)),U,10)
if EASDFN
QUIT
+16 DO FULL^VALM1
WRITE @IOF
+17 SET EASEZNEW=""
SET ELIGVER=0
SET SVCVER=0
SET APPTVER=0
+18 SET KEY=$$KEY711^EASEZU1("APPLICANT SEX")
+19 SET SEX=$PIECE($$DATA712^EASEZU1(EASAPP,KEY),U,1)
SET SEX=$SELECT(SEX="M":"Male",SEX="F":"Female",1:"")
+20 SET DIQ="ARRAY"
SET DIQ(0)="E"
SET DA=EASAPP
SET DR="1;2;3;3.3"
SET DIC=712
DO EN^DIQ1
+21 SET NAME=$GET(ARRAY(712,EASAPP,1,"E"))
+22 SET SSN=$PIECE($GET(ARRAY(712,EASAPP,2,"E")),"&",1)
+23 SET DOB=$PIECE($GET(ARRAY(712,EASAPP,2,"E")),"&",2)
+24 SET RECD=$GET(ARRAY(712,EASAPP,3,"E"))
+25 SET VETTYPE=$GET(ARRAY(712,EASAPP,3.3,"E"))
+26 WRITE !,"Applicant Data",?24,"Application #: ",EASAPP,?48,"Received: ",RECD,!
+27 WRITE !,"Name: ",NAME
+28 WRITE !,"SSN: ",SSN,?24,"DOB: ",DOB,?48,"Sex: ",SEX
+29 WRITE !,"Veteran Type: ",VETTYPE
+30 WRITE !!,"Enter Applicant data as prompted --"
+31 ;
+32 ;Get Patient file (#2) IEN - DFN
+33 ;EAS*1*81 - changes made to allow adding new patient with same name
+34 ;as an existing patient
+35 NEW EASANS,Y
SET EASANS=0
+36 NEW DIR,DIRUT
+37 SET DIR(0)="YAO"
+38 SET DIR("?")="Enter 'Yes' if this patient is the one you want to select."
+39 SET DIR("A")="IS THIS THE CORRECT PATIENT? "
+40 SET DIR("B")="YES"
+41 FOR
if EASANS
QUIT
Begin DoDot:1
+42 DO GETPAT^DGRPTU("",1,.DFN,.DGNEWPF)
IF DFN>0
IF ($GET(DGNEWPF)=1)
SET EASANS=1
QUIT
+43 IF DFN'>0
SET EASANS=1
QUIT
+44 IF DFN>0
IF ($GET(DGNEWPF)'=1)
Begin DoDot:2
+45 DO ^DIR
+46 IF $DATA(DIRUT)
QUIT
+47 IF Y(0)["Y"
SET EASANS=1
QUIT
+48 IF Y(0)["N"
KILL DFN
+49 IF $GET(DFN)'>0
Begin DoDot:3
End DoDot:3
+50 WRITE !!?5,"If there are already one or more patients with the same name,",!?5,"re-enter the name in double quotes, for example, ""DOE,JOHN""."
End DoDot:2
End DoDot:1
KILL DIR
+51 if ($GET(DFN)'>0)
QUIT
+52 ;if DGNEWPF=1 then applicant has just been added to file #2 as new patient
+53 SET NEW=""
+54 IF DGNEWPF
Begin DoDot:1
+55 SET NEW=1
+56 ;add a remark to file #2 record to help keep track of new patients added by 1010EZ
+57 SET REM="NEW PT. FROM ELECTRONIC 10-10EZ -- IN PROCESS"
+58 SET DA=DFN
SET DIE="^DPT("
SET DR=".091///^S X=REM"
+59 DO ^DIE
End DoDot:1
+60 ;if seems to be not new, check remark field just to make sure
+61 IF NEW=""
Begin DoDot:1
+62 SET REM="NEW PT. FROM ELECTRONIC 10-10EZ -- IN PROCESS"
+63 IF $PIECE(^DPT(DFN,0),U,10)=REM
SET NEW=1
End DoDot:1
+64 ;MPI Query
+65 SET X="MPIFAPI"
XECUTE ^%ZOSF("TEST")
Begin DoDot:1
+66 if '$TEST
QUIT
+67 KILL MPIFRTN
+68 DO MPIQ^MPIFAPI(DFN)
+69 KILL MPIFRTN,MPIQRYNM
End DoDot:1
+70 ;check for an in-process application already linked to this DFN
+71 SET OUT=0
SET ALREADY=0
FOR
SET ALREADY=$ORDER(^EAS(712,"AC",DFN,ALREADY))
if 'ALREADY
QUIT
Begin DoDot:1
+72 SET FILDATE=$PIECE($GET(^EAS(712,ALREADY,2)),U,5)
+73 SET CLSDATE=$PIECE($GET(^EAS(712,ALREADY,2)),U,9)
+74 IF 'FILDATE
IF 'CLSDATE
SET OUT=1
Begin DoDot:2
+75 WRITE !!?3,"Sorry... cannot link to selected Patient."
+76 WRITE !?3,"Application #"_ALREADY_" is already linked to this Patient,"
+77 WRITE !?3,"and is still in-process."
+78 DO PAUSE^VALM1
KILL FILDATE,CLSDATE
End DoDot:2
End DoDot:1
if OUT
QUIT
+79 if OUT
QUIT
+80 DO RESET^EASEZI1
+81 QUIT
+82 ;
I201(EASDFN,EASARRAY) ;retrieve ien(s) in subfile #2.01
+1 ;input EASDFN = ien to #2
+2 ;output EASARRAY = ien(s) to #2.01
+3 ; each array element = EASDFN;subfile_ien
+4 ;
+5 NEW N,IEN
+6 SET IEN=0
SET N=0
FOR
SET IEN=$ORDER(^DPT(EASDFN,.01,IEN))
if 'IEN
QUIT
SET N=N+1
SET EASARRAY(N)=EASDFN_";"_IEN
+7 QUIT
+8 ;
I202(EASDFN,EASARRAY) ;retrieve ien(s) in subfile #2.02
+1 ;input EASDFN = ien to #2
+2 ;output EASARRAY = ien(s) to #2.01
+3 ; each array element = EASDFN;subfile_ien
+4 ;
+5 NEW N,IEN
+6 SET IEN=0
SET N=0
FOR
SET IEN=$ORDER(^DPT(EASDFN,.02,IEN))
if 'IEN
QUIT
SET N=N+1
SET EASARRAY(N)=EASDFN_";"_IEN
+7 QUIT
+8 ;
I206(EASDFN,EASARRAY) ;retrieve ien(s) in subfile #2.06
+1 ;input EASDFN = ien to #2
+2 ;output EASARRAY = ien(s) to #2.01
+3 ; each array element = EASDFN;subfile_ien
+4 ;
+5 NEW N,IEN
+6 SET IEN=0
SET N=0
FOR
SET IEN=$ORDER(^DPT(EASDFN,.06,IEN))
if 'IEN
QUIT
SET N=N+1
SET EASARRAY(N)=EASDFN_";"_IEN
+7 QUIT
+8 ;
I2101(EASDFN,EASARRAY) ;retrieve ien to subfile #2.101
+1 ;input EASDFN = ien to #2
+2 ;output EASARRAY = most recent ien in #2.101;
+3 ; array element = EASDFN;subfile_ien
+4 ;
+5 NEW N,IEN,ARR,LAST,EASQUIT,EASICN
+6 SET EASQUIT=0
+7 SET IEN=0
SET N=0
FOR
SET IEN=$ORDER(^DPT(EASDFN,"DIS",IEN))
if 'IEN!EASQUIT
QUIT
Begin DoDot:1
+8 ;S RDATE=$P(^DPT(EASDFN,"DIS",IEN,0),U,1),ARR(RDATE)=IEN
+9 SET RDATE=$PIECE($GET(^DPT(EASDFN,"DIS",IEN,0)),U,1)
IF RDATE]""
SET ARR(RDATE)=IEN
+10 IF RDATE']""
Begin DoDot:2
+11 KILL XQA,XQAID,XQAMSG
+12 SET EASICN=$$GETICN^MPIF001(EASDFN)
IF EASICN]""
SET EASICN=$PIECE(EASICN,"V",1)
+13 SET XQA(DUZ)=""
+14 SET XQAID="EAS"
+15 SET XQAMSG="No disposition for "_$PIECE(^DPT(EASDFN,0),"^",1)_" ICN: "_EASICN_" Re-register patient."
+16 ;S $P(XQADATA,"^",1)="NAME : "_$P(^DPT(EASDFN,0),"^",1) ;PATIENT NAME
+17 DO SETUP^XQALERT
+18 ; S EASQUIT=1 K ^DPT(EASDFN,"DIS",IEN),^DPT("ADA",1,EASDFN),ARR
+19 SET EASQUIT=1
Begin DoDot:3
+20 KILL ARR,DA,DA(1),DIK,EASNODE,EASDT
+21 SET DA=IEN
SET DA(1)=EASDFN
SET DIK="^DPT("_EASDFN_",""DIS"","
DO ^DIK
KILL DIK,DA
+22 IF $DATA(^DPT("ADA",1,EASDFN))
SET EASDT=$ORDER(^DPT("ADA",1,EASDFN,0))
SET EASNODE="^DPT(""ADA"""_",1,"_EASDFN_","_EASDT_")"
KILL @EASNODE
+23 QUIT
End DoDot:3
+24 IF '$DATA(IO("Q"))
Begin DoDot:3
+25 WRITE !!,"No disposition for "_$PIECE(^DPT(EASDFN,0),"^",1)_" ICN: "_EASICN
+26 WRITE !,"A blank 1010EZ may print. Please re-register the patient and reprint the 1010EZ."
+27 HANG 6
End DoDot:3
+28 ; D ENQUIT^EASEZPF ; KILLS ALL OF THE ^TMP("EZ" VARIABLES FOR PRINTING1010EZ.
+29 SET EASARRAY(1)="NO DISPOSITION"
QUIT
End DoDot:2
End DoDot:1
+30 IF $DATA(ARR)
Begin DoDot:1
+31 SET LAST=$ORDER(ARR(999999999),-1)
SET IEN=ARR(LAST)
+32 SET EASARRAY(1)=EASDFN_";"_IEN
End DoDot:1
+33 QUIT
+34 ;
I2711(EASDFN,EASARRAY) ;retrieve ien to file #27.11
+1 ;input EASDFN = ien to #2
+2 ;output EASARRAY = current enrollment ien in #27.11;
+3 ; array element = ien
+4 NEW CUR
+5 SET CUR=$$FINDCUR^DGENA(+EASDFN)
+6 SET EASARRAY(1)=CUR
+7 QUIT
+8 ;
I408(EASDFN,EASAPP,EASARRAY) ;retrieve ien(s) to files #408.12,#408.13,#408.21,#408.22
+1 ;
+2 ;input EASDFN = ien to #2
+3 ; EASAPP = ien to #712
+4 ;output EASARRAY = ien(s) to files; passed by reference
+5 ; array(408,"V",1) = ien_#408.12^ien_#408.13^ien_#408.21^ien#408.22 ;veteran data
+6 ; array(408,"S",1) = ien_#408.12^ien_#408.13^ien_#408.21^ien#408.22 ;spouse data
+7 ; array(408,"C",multiple) = ien_#408.12^ien_#408.13^ien_#408.21^ien#408.22 ;child data
+8 ; where ien_#408.13 = ien;global_root
+9 ;
+10 NEW CURINCYR,X,Y,DIC,DA,DR,DIQ,EAS,DEP,REL,IX,JX,KX,I13,SUB1,SUB2,INCYR,PT
+11 ;
+12 if 'EASDFN
QUIT
+13 SET Y=$PIECE($GET(^EAS(712,EASAPP,0)),U,6)
IF Y=""
SET Y=DT
+14 SET %F=5
SET X=$$FMTE^XLFDT(Y,%F)
SET X=+$PIECE(X,"/",3)-1
SET %DT="P"
DO ^%DT
SET CURINCYR=Y
+15 ;find all associated 408 records, even if no actual income test
+16 ; get #408.12, #408.13, #408.21, #408.22 iens
+17 KILL EAS
SET DEP=0
+18 SET IX=0
FOR
SET IX=$ORDER(^DGPR(408.12,"B",EASDFN,IX))
if 'IX
QUIT
Begin DoDot:1
+19 SET DIC=408.12
SET DA=IX
SET DIQ="EAS"
SET DIQ(0)="I"
SET DR=".02;.03"
DO EN^DIQ1
+20 SET REL=$GET(EAS(408.12,IX,.02,"I"))
SET I13=$GET(EAS(408.12,IX,.03,"I"))
+21 SET (SUB1,SUB2)=""
if REL=1
SET SUB1="V"
SET SUB2=1
if REL=2
SET SUB1="S"
SET SUB2=1
if REL>2
SET SUB1="C"
SET DEP=DEP+1
SET SUB2=DEP
+22 IF SUB1]""
SET EASARRAY(408,SUB1,SUB2)=IX_U_I13
Begin DoDot:2
+23 SET JX=$ORDER(^DGMT(408.21,"C",IX,""),-1)
+24 IF JX
Begin DoDot:3
+25 SET DIC=408.21
SET DA=JX
SET DIQ="EAS"
SET DIQ(0)="I"
SET DR=".01;.02"
DO EN^DIQ1
+26 SET INCYR=$GET(EAS(408.21,JX,.01,"I"))
SET PT=$GET(EAS(408.21,JX,.02,"I"))
+27 if PT'=IX
QUIT
+28 if (INCYR<CURINCYR)
QUIT
+29 SET KX=$ORDER(^DGMT(408.22,"AIND",JX,0))
+30 SET EASARRAY(408,SUB1,SUB2)=EASARRAY(408,SUB1,SUB2)_U_JX_U_KX
End DoDot:3
End DoDot:2
End DoDot:1
+31 QUIT
+32 ;
I1275(IEN) ;get the active subrecord from subfile #408.1275
+1 ;input IEN = internal record number to file #408.12
+2 ;output SUBIEN = internal record number for active subrecord,
+3 ; or -1 if invalid
+4 NEW B,ACT,SUBIEN
+5 IF 'IEN
QUIT -1
+6 SET SUBIEN=-1
+7 SET B=0
FOR
SET B=$ORDER(^DGPR(408.12,IEN,"E",B))
if 'B
QUIT
Begin DoDot:1
+8 SET ACT=$PIECE(^DGPR(408.12,IEN,"E",B,0),U,2)
+9 IF ACT
SET SUBIEN=B
End DoDot:1
+10 QUIT SUBIEN
