DGSSNRP2 ;ALB/SEK/PHH - DUPLICATE SPOUSE/DEPENDENT Report - Continued; 04/07/2004
;;5.3;Registration;**313,535,568**;Aug 13,1993
;
MAIN ;
N X S X=$$DT^XLFDT
S ^XTMP("DG-SSNRP2",0)=X+1_U_X_"^DG DUPLICATE SSN REPORT "
D GETDATA
I $D(ZTQUEUED) D
.N ZTRTN,ZTDESC,ZTSK,ZTIO
.S ZTRTN="PRINT^DGSSNRP2",ZTDESC="Duplicate Spouse/Dependent SSN Report",ZTIO="`"_DEV
.S:$D(HFS) IO("HFSIO")=HFS
.S:$D(PAR) IOPAR=PAR
.D ^%ZTLOAD
.S ZTREQ="@"
E S IOP="`"_IOS D ^%ZIS,PRINT,HOME^%ZIS
Q
PRINT ;
N STATS,CRT,QUIT,PAGE,PART1D,PART2D,PART1ST,SECTION,DGVETNM,DGVETSSN,VA,VADM,VAERR
K DEV,HFS,PAR
S (QUIT,PAGE)=0,CRT=$S($E(IOST,1,2)="C-":1,1:0)
U IO
I CRT,PAGE=0 W @IOF
S (PAGE,PART1D,PART2D)=1,SECTION="PART1"
D CHECKP1,HEADER
I PART1D D PPART1
I QUIT K ^XTMP("DG-SSNRP2") Q
S SECTION="PART2"
S:'$D(^XTMP("DG-SSNRP2","DGPART2")) PART2D=0
D HEADER
I PART2D D PPART2
I CRT,'QUIT D PAUSE
I $D(ZTQUEUED) S ZTREQ="@"
D ^%ZISC
K ^XTMP("DG-SSNRP2"),^TMP("DGSSNAR",$J)
Q
LINE(LINE) ; Prints header if end of page.
I CRT,($Y>(IOSL-4)) D Q:QUIT
.D PAUSE
.Q:QUIT
.W @IOF
.D HEADER Q:QUIT
.W:SECTION="PART1" !
.W LINE
;
E I ('CRT),($Y>(IOSL-2)) D
.W @IOF
.D HEADER
.W !,LINE
;
E W !,LINE
Q
;
GETDATA ;Setup global with vets included in the report
D GETPART1
D GETPART2
Q
;
GETPART1 ;1st part of report
;S ^XTMP("DG-SSNRP2","DGPART1",DGVETSSN)=DGVETNM
;S ^XTMP("DG-SSNRP2","DGPART1",DGVETSSN,DGCTR1)=DGDEPNM^DGDEPSSN^DGDEPREL
N DFN,DG40812,DGDEP,DGDEPIEN,DGIEN,DGSSNCTR,VARR
K ^TMP("DGSSNAR",$J) S VARR=1
S DFN=0 F S DFN=$O(^DGPR(408.12,"B",DFN)) Q:'DFN D
.S (DGIEN,DGSSNCTR)=0
.F S DGIEN=$O(^DGPR(408.12,"B",DFN,DGIEN)) D Q:'DGIEN
..Q:'DGIEN
..S DG40812=$G(^DGPR(408.12,DGIEN,0)) Q:'DG40812
..I DG40812["DPT" D Q
...;if can't get veteran's SSN kill array and get next veteran
...D DEM^VADPT
...I '$P(VADM(2),"^") K ^TMP("DGSSNAR",$J,DFN) S DGIEN="" Q
...; Check if patient has a Date of Death
...I '$$OKRPT(DFN,.VADM) Q
...; Check if patient was IN/OUT patient in last 3 years
...I $$OKIMP(DFN)
...;^TMP("DGSSNAR",$J) for vet (subscript "V") = name^SSN (no P)^SSN (with P)
...S ^TMP("DGSSNAR",$J,DFN,"V")=VADM(1)_"^"_$TR(VADM(2),"-P","")_"^"_$P(VADM(2),"^")
..;^TMP("DGSSNAR",$J) for dependents = SSN or Not Available^name^relationship code
..I DG40812["DGPR" D Q
...S DGDEPIEN=$P($P(DG40812,"^",3),";") Q:'DGDEPIEN
...S DGDEP=$G(^DGPR(408.13,DGDEPIEN,0)) Q:DGDEP']""
...S DGSSNCTR=DGSSNCTR+1
...S ^TMP("DGSSNAR",$J,DFN,"D",DGSSNCTR)=$S($P(DGDEP,"^",9):$P(DGDEP,"^",9),1:"Not Available")_"^"_$P(DGDEP,"^")_"^"_$P(DG40812,"^",2)
.D:$D(^TMP("DGSSNAR",$J,DFN)) VBLDARR(DFN)
;
D SDAM,SETTMPA
Q
;
SETTMPA ;check if spouse/dep SSN is the same as the vet's SSN or if not available (missing)
N DGDEPSSN,DGSCTR,DGTMPN1,DGVETSNP,AFLG,APPCK,APPTYP
S DFN=0 F S DFN=$O(^TMP("DGSSNAR",$J,DFN)) Q:'DFN D
.; Only want appts kept in the last 3 years
.I '$$OK2RPT(DFN) K ^TMP("DGSSNAR",$J,DFN),^TMP($J,"SDAMA",DFN) Q
.S DGSSNCTR=+($O(^TMP("DGSSNAR",$J,DFN,"D",""),-1))
.I ('DGSSNCTR)!('$D(^TMP("DGSSNAR",$J,DFN,"V"))) K ^TMP("DGSSNAR",$J,DFN) Q
.S DGVETSNP=$P(^TMP("DGSSNAR",$J,DFN,"V"),"^",2)
.S DGTMPN1=0
.F DGSCTR=1:1:DGSSNCTR D
..S DGDEPSSN=$P(^TMP("DGSSNAR",$J,DFN,"D",DGSCTR),"^")
..Q:((DGDEPSSN'=DGVETSNP)&(DGDEPSSN))
..I 'DGTMPN1 S ^XTMP("DG-SSNRP2","DGPART1",("A"_$P(^TMP("DGSSNAR",$J,DFN,"V"),"^",3)))=$P(^TMP("DGSSNAR",$J,DFN,"V"),"^"),DGTMPN1=1
..S ^XTMP("DG-SSNRP2","DGPART1",("A"_$P(^TMP("DGSSNAR",$J,DFN,"V"),"^",3)),DGSCTR)=$P(^TMP("DGSSNAR",$J,DFN,"D",DGSCTR),"^",2)_"^"_DGDEPSSN_"^"_$P(^TMP("DGSSNAR",$J,DFN,"D",DGSCTR),"^",3)
Q
;
GETPART2 ;2nd part of report
;S ^XTMP("DG-SSNRP2","DGPART2",DGDEPSSN,DGCTR2)=DGDEPNM^DGDEPEL^DGVETSSN
N DGSSN,DGSSND,DGSSNDA,DGSSN1,DGSSNCTR
K ^TMP("DGSSNAR",$J)
S DGSSN=0 F S DGSSN=$O(^DGPR(408.13,"SSN",DGSSN)) D Q:'DGSSN
.Q:'DGSSN
.S DGSSN1="A"_DGSSN
.S (DGSSNDA,DGSSNCTR)=0
.F S DGSSNDA=$O(^DGPR(408.13,"SSN",DGSSN,DGSSNDA)) D Q:'DGSSNDA
..Q:'DGSSNDA
..S DGSSND=$G(^DGPR(408.13,DGSSNDA,0)) Q:DGSSND']""
..;^TMP("DGSSNAR",$J) array = IEN of INCOME PERSON file (#408.13)^dependent name
..S DGSSNCTR=DGSSNCTR+1
..S ^TMP("DGSSNAR",$J,DGSSN1,DGSSNCTR)=DGSSNDA_"^"_$P(DGSSND,"^")
;
D SELPRT2,SDAM,SETTMP
Q
;
SETTMP ; Spouse/dependent with the same SSN
N DGSSNCTR,DGDEPNM,DGDEPREL,DGPAT,DGPATRL,DGSCTR,DGSSNDA1,DGVETSN2
S DGSSN="" F S DGSSN=$O(^TMP("DGSSNAR",$J,DGSSN)) Q:DGSSN="" D
.S DGSSNCTR=+($O(^TMP("DGSSNAR",$J,DGSSN,""),-1))
.F DGSCTR=1:1:DGSSNCTR D
..S DGSSNDA1=$P(^TMP("DGSSNAR",$J,DGSSN,DGSCTR),"^")
..S DGDEPNM=$P(^TMP("DGSSNAR",$J,DGSSN,DGSCTR),"^",2)
..S DGPAT=$O(^DGPR(408.12,"C",DGSSNDA1_";DGPR(408.13,",0))
..S DGPATRL=$G(^DGPR(408.12,+DGPAT,0))
..;missing "C" x-ref or 0 node of 408.12 record
..I 'DGPATRL S DGDEPREL="U",DGVETSN2="UNKNOWN"
..E D I +DGVETSN2 Q:'$$OK2RPT(DFN)
...S DFN=+DGPATRL
...D DEM^VADPT
...S DGVETSN2=$P($G(VADM(2)),"^")
...S DGDEPREL=$P(DGPATRL,"^",2)
..S ^XTMP("DG-SSNRP2","DGPART2",DGSSN,DGSCTR)=DGDEPNM_"^"_DGDEPREL_"^"_DGVETSN2
Q
;
CHECKP1 ;if there is no part1 data S PART1D=0
;if data S PART1ST=1 indicating 1st time thru header
I '$D(^XTMP("DG-SSNRP2","DGPART1")) S PART1D=0 Q
S PART1ST=1
Q
;
Q:QUIT
N LINE
I $Y>1 W @IOF
W !,?21,"Duplicate Spouse/Dependent SSN Report"
W ?70,"Page ",PAGE,!,?26,"Date Generated: "_$$FMTE^XLFDT(DT)
S PAGE=PAGE+1
;
W !,$S(SECTION="PART1":" Spouse/Dependent with no SSN or the same SSN as Veteran",1:" Spouse/Dependent with the same SSN as another Spouse/Dependent")
I SECTION="PART1" D
.I 'PART1D,$D(^TMP($J,"SDAMA","ERR")) W !!,?10,"Appointment Database Unavailable to validate active veterans." Q
.I 'PART1D W !!,?25,"No entries meet this criteria" Q
.I 'PART1ST D PART1HD Q
.S PART1ST=0
I SECTION="PART2" D
.W !!
.I 'PART2D,$D(^TMP($J,"SDAMA","ERR")) W !!,?10,"Appointment Database Unavailable to validate active veterans." Q
.I 'PART2D W ?25,"No entries meet this criteria" Q
.W "Spouse/Dependent Name",?33,"Spouse/Dependent SSN",?55,"Relationship",?69,"Veteran SSN"
Q
;
PAUSE N DIR,DIRUT,X,Y
F Q:$Y>(IOSL-3) W !
S DIR(0)="E" D ^DIR
I ('(+Y))!$D(DIRUT) S QUIT=1
Q
;
PPART1 ;Description: Prints Part 1 - Spouse/Dependent with no SSN or the same SSN as Veteran
N DGPART1,DGSCTR,LINE S DGVETSSN=0
F S DGVETSSN=$O(^XTMP("DG-SSNRP2","DGPART1",DGVETSSN)) Q:DGVETSSN']"" D Q:QUIT
.S DGSCTR=0,DGVETNM=$G(^XTMP("DG-SSNRP2","DGPART1",DGVETSSN))
.Q:QUIT D PART1HEA Q:QUIT
.F S DGSCTR=$O(^XTMP("DG-SSNRP2","DGPART1",DGVETSSN,DGSCTR)) Q:'DGSCTR D Q:QUIT
..S DGPART1=$G(^XTMP("DG-SSNRP2","DGPART1",DGVETSSN,DGSCTR))
..Q:DGPART1']""
..S LINE=$$LJ(" "_$P(DGPART1,"^"),25)_" "_$$LJ($P(DGPART1,"^",2),22)
..S LINE=LINE_$$LJ($$RELCODE($P(DGPART1,"^",3)),12)
..D LINE(LINE) Q:QUIT
..Q:QUIT
.Q:QUIT
Q
;
PPART2 ;Description: Prints Part 2 -Spouse/Dependent with the same SSN as another Spouse/Dependent
N DGDEPSSN,DGPART2,DGP2F,DGSCTR,LINE
S DGP2F=1,DGDEPSSN=0
F S DGDEPSSN=$O(^XTMP("DG-SSNRP2","DGPART2",DGDEPSSN)) Q:DGDEPSSN']"" D Q:QUIT
.I 'DGP2F W !
.E S DGP2F=0
.S DGSCTR=0
.F S DGSCTR=$O(^XTMP("DG-SSNRP2","DGPART2",DGDEPSSN,DGSCTR)) Q:'DGSCTR D Q:QUIT
..S DGPART2=$G(^XTMP("DG-SSNRP2","DGPART2",DGDEPSSN,DGSCTR))
..Q:DGPART2']""
..S LINE=$$LJ(" "_$P(DGPART2,"^"),29)_" "_$$LJ($E(DGDEPSSN,2,10),21)
..S LINE=LINE_$$LJ($$RELCODE($P(DGPART2,"^",2)),13)
..S LINE=LINE_$$LJ(" "_$P(DGPART2,"^",3),10)
..D LINE(LINE) Q:QUIT
..Q:QUIT
.Q:QUIT
Q
;
LJ(STRING,LENGTH) ;
Q $$LJ^XLFSTR($E(STRING,1,LENGTH),LENGTH)
;
RELCODE(DGCODE) ;returns relationship name from RELATIONSHIP file (#408.11)
;
N DGNAME S DGNAME=$P($G(^DG(408.11,+DGCODE,0)),"^")
I DGNAME']"" Q "UNKNOWN"
Q DGNAME
;
PART1HEA ;heading for part1 (vet name & SSN and spouse/dep name & SSN)
I ('CRT),($Y>(IOSL-6)) D Q
.D HEADER
;
E I CRT,($Y>(IOSL-8)) D Q:QUIT
.D PAUSE
.Q:QUIT
.D HEADER
;
E D PART1HD
Q
;
PART1HD W !!,"Veteran: ",$$LJ(DGVETNM,30)," Veteran SSN: ",$$LJ($E(DGVETSSN,2,11),10),!!," Spouse/Dependent Name Spouse/Dependent SSN Relationship"
Q
OKRPT(DFN,VADM) ; Date of Death?
N X,X1,X2
I '$D(VADM) D DEM^VADPT
I +VADM(6) Q 0
Q 1
;
OKIMP(DFN) ; Inpatient or Outpatient in the last 3 years?
N VAIP S VAIP("D")="LAST" D IN5^VADPT
I VAIP(3)'="" D Q '(X>1095)
.S X1=DT,X2=$P(VAIP(3),U)\1 D ^%DTC
.I X<1096 S ^TMP($J,"SDAMA",DFN,+VAIP(3))="^^I;INPATIENT"
Q 1
;
OK2RPT(DFN) ; Appt kept in the last 3 years?
N APPCK,AFLG S (APPCK,AFLG)=0
F S APPCK=$O(^TMP($J,"SDAMA",DFN,APPCK)) Q:'APPCK!(AFLG) D
.S APPTYP=$P($P(^TMP($J,"SDAMA",DFN,APPCK),U,3),";")
.I "^R^I^"[(U_APPTYP_U) S AFLG=1
Q AFLG
;
VBLDARR(DFN) ; Build array of specified veterans
S ^TMP($J,"SDAMAPI",VARR)=$G(^TMP($J,"SDAMAPI",VARR))_DFN_";"
I $L(^TMP($J,"SDAMAPI",VARR))>180 S VARR=VARR+1
Q
;
SDAM N DGARRAY,I,SDCNT
S DGARRAY(1)=$$FMADD^XLFDT(DT,-1095)_";"_DT,DGARRAY("FLDS")=3,DGARRAY("SORT")="P"
F I=1:1 Q:'$D(^TMP($J,"SDAMAPI",I)) D
.S DGARRAY(4)=^TMP($J,"SDAMAPI",I)
.S SDCNT=$$SDAPI^SDAMA301(.DGARRAY)
.I SDCNT'>0 K ^TMP($J,"SDAMA301"),^TMP($J,"SDAMAPI",I) Q
.M ^TMP($J,"SDAMA")=^TMP($J,"SDAMA301")
.K ^TMP($J,"SDAMA301"),^TMP($J,"SDAMAPI",I)
I '$D(^TMP($J,"SDAMA")) S ^TMP($J,"SDAMA","ERR")=""
Q
;
SELPRT2 ; Select records for Part 2
N DGSSN,DGCNT,DGSSNP,DGPTR,DGPTRL,VARR S VARR=1
S DGSSN="" F S DGSSN=$O(^TMP("DGSSNAR",$J,DGSSN)) Q:DGSSN="" D
.S DGCNT=$O(^TMP("DGSSNAR",$J,DGSSN,""),-1)
.I DGCNT<2 K ^TMP("DGSSNAR",$J,DGSSN) Q
.S DGSSNP=$P(^TMP("DGSSNAR",$J,DGSSN,DGCNT),U)
.S DGPTR=$O(^DGPR(408.12,"C",DGSSNP_";DGPR(408.13,",0))
.S DGPTRL=+$G(^DGPR(408.12,+DGPTR,0))
.I $$OKIMP(DGPTRL)
.Q:$D(^TMP($J,"SDAMA",DGPTRL))
.D VBLDARR(DGPTRL)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGSSNRP2 9987 printed Apr 09, 2024@21:57:28 Page 2
DGSSNRP2 ;ALB/SEK/PHH - DUPLICATE SPOUSE/DEPENDENT Report - Continued; 04/07/2004
+1 ;;5.3;Registration;**313,535,568**;Aug 13,1993
+2 ;
MAIN ;
+1 NEW X
SET X=$$DT^XLFDT
+2 SET ^XTMP("DG-SSNRP2",0)=X+1_U_X_"^DG DUPLICATE SSN REPORT "
+3 DO GETDATA
+4 IF $DATA(ZTQUEUED)
Begin DoDot:1
+5 NEW ZTRTN,ZTDESC,ZTSK,ZTIO
+6 SET ZTRTN="PRINT^DGSSNRP2"
SET ZTDESC="Duplicate Spouse/Dependent SSN Report"
SET ZTIO="`"_DEV
+7 if $DATA(HFS)
SET IO("HFSIO")=HFS
+8 if $DATA(PAR)
SET IOPAR=PAR
+9 DO ^%ZTLOAD
+10 SET ZTREQ="@"
End DoDot:1
+11 IF '$TEST
SET IOP="`"_IOS
DO ^%ZIS
DO PRINT
DO HOME^%ZIS
+12 QUIT
PRINT ;
+1 NEW STATS,CRT,QUIT,PAGE,PART1D,PART2D,PART1ST,SECTION,DGVETNM,DGVETSSN,VA,VADM,VAERR
+2 KILL DEV,HFS,PAR
+3 SET (QUIT,PAGE)=0
SET CRT=$SELECT($EXTRACT(IOST,1,2)="C-":1,1:0)
+4 USE IO
+5 IF CRT
IF PAGE=0
WRITE @IOF
+6 SET (PAGE,PART1D,PART2D)=1
SET SECTION="PART1"
+7 DO CHECKP1
DO HEADER
+8 IF PART1D
DO PPART1
+9 IF QUIT
KILL ^XTMP("DG-SSNRP2")
QUIT
+10 SET SECTION="PART2"
+11 if '$DATA(^XTMP("DG-SSNRP2","DGPART2"))
SET PART2D=0
+12 DO HEADER
+13 IF PART2D
DO PPART2
+14 IF CRT
IF 'QUIT
DO PAUSE
+15 IF $DATA(ZTQUEUED)
SET ZTREQ="@"
+16 DO ^%ZISC
+17 KILL ^XTMP("DG-SSNRP2"),^TMP("DGSSNAR",$JOB)
+18 QUIT
LINE(LINE) ; Prints header if end of page.
+1 IF CRT
IF ($Y>(IOSL-4))
Begin DoDot:1
+2 DO PAUSE
+3 if QUIT
QUIT
+4 WRITE @IOF
+5 DO HEADER
if QUIT
QUIT
+6 if SECTION="PART1"
WRITE !
+7 WRITE LINE
End DoDot:1
if QUIT
QUIT
+8 ;
+9 IF '$TEST
IF ('CRT)
IF ($Y>(IOSL-2))
Begin DoDot:1
+10 WRITE @IOF
+11 DO HEADER
+12 WRITE !,LINE
End DoDot:1
+13 ;
+14 IF '$TEST
WRITE !,LINE
+15 QUIT
+16 ;
GETDATA ;Setup global with vets included in the report
+1 DO GETPART1
+2 DO GETPART2
+3 QUIT
+4 ;
GETPART1 ;1st part of report
+1 ;S ^XTMP("DG-SSNRP2","DGPART1",DGVETSSN)=DGVETNM
+2 ;S ^XTMP("DG-SSNRP2","DGPART1",DGVETSSN,DGCTR1)=DGDEPNM^DGDEPSSN^DGDEPREL
+3 NEW DFN,DG40812,DGDEP,DGDEPIEN,DGIEN,DGSSNCTR,VARR
+4 KILL ^TMP("DGSSNAR",$JOB)
SET VARR=1
+5 SET DFN=0
FOR
SET DFN=$ORDER(^DGPR(408.12,"B",DFN))
if 'DFN
QUIT
Begin DoDot:1
+6 SET (DGIEN,DGSSNCTR)=0
+7 FOR
SET DGIEN=$ORDER(^DGPR(408.12,"B",DFN,DGIEN))
Begin DoDot:2
+8 if 'DGIEN
QUIT
+9 SET DG40812=$GET(^DGPR(408.12,DGIEN,0))
if 'DG40812
QUIT
+10 IF DG40812["DPT"
Begin DoDot:3
+11 ;if can't get veteran's SSN kill array and get next veteran
+12 DO DEM^VADPT
+13 IF '$PIECE(VADM(2),"^")
KILL ^TMP("DGSSNAR",$JOB,DFN)
SET DGIEN=""
QUIT
+14 ; Check if patient has a Date of Death
+15 IF '$$OKRPT(DFN,.VADM)
QUIT
+16 ; Check if patient was IN/OUT patient in last 3 years
+17 IF $$OKIMP(DFN)
+18 ;^TMP("DGSSNAR",$J) for vet (subscript "V") = name^SSN (no P)^SSN (with P)
+19 SET ^TMP("DGSSNAR",$JOB,DFN,"V")=VADM(1)_"^"_$TRANSLATE(VADM(2),"-P","")_"^"_$PIECE(VADM(2),"^")
End DoDot:3
QUIT
+20 ;^TMP("DGSSNAR",$J) for dependents = SSN or Not Available^name^relationship code
+21 IF DG40812["DGPR"
Begin DoDot:3
+22 SET DGDEPIEN=$PIECE($PIECE(DG40812,"^",3),";")
if 'DGDEPIEN
QUIT
+23 SET DGDEP=$GET(^DGPR(408.13,DGDEPIEN,0))
if DGDEP']""
QUIT
+24 SET DGSSNCTR=DGSSNCTR+1
+25 SET ^TMP("DGSSNAR",$JOB,DFN,"D",DGSSNCTR)=$SELECT($PIECE(DGDEP,"^",9):$PIECE(DGDEP,"^",9),1:"Not Available")_"^"_$PIECE(DGDEP,"^")_"^"_$PIECE(DG40812,"^",2)
End DoDot:3
QUIT
End DoDot:2
if 'DGIEN
QUIT
+26 if $DATA(^TMP("DGSSNAR",$JOB,DFN))
DO VBLDARR(DFN)
End DoDot:1
+27 ;
+28 DO SDAM
DO SETTMPA
+29 QUIT
+30 ;
SETTMPA ;check if spouse/dep SSN is the same as the vet's SSN or if not available (missing)
+1 NEW DGDEPSSN,DGSCTR,DGTMPN1,DGVETSNP,AFLG,APPCK,APPTYP
+2 SET DFN=0
FOR
SET DFN=$ORDER(^TMP("DGSSNAR",$JOB,DFN))
if 'DFN
QUIT
Begin DoDot:1
+3 ; Only want appts kept in the last 3 years
+4 IF '$$OK2RPT(DFN)
KILL ^TMP("DGSSNAR",$JOB,DFN),^TMP($JOB,"SDAMA",DFN)
QUIT
+5 SET DGSSNCTR=+($ORDER(^TMP("DGSSNAR",$JOB,DFN,"D",""),-1))
+6 IF ('DGSSNCTR)!('$DATA(^TMP("DGSSNAR",$JOB,DFN,"V")))
KILL ^TMP("DGSSNAR",$JOB,DFN)
QUIT
+7 SET DGVETSNP=$PIECE(^TMP("DGSSNAR",$JOB,DFN,"V"),"^",2)
+8 SET DGTMPN1=0
+9 FOR DGSCTR=1:1:DGSSNCTR
Begin DoDot:2
+10 SET DGDEPSSN=$PIECE(^TMP("DGSSNAR",$JOB,DFN,"D",DGSCTR),"^")
+11 if ((DGDEPSSN'=DGVETSNP)&(DGDEPSSN))
QUIT
+12 IF 'DGTMPN1
SET ^XTMP("DG-SSNRP2","DGPART1",("A"_$PIECE(^TMP("DGSSNAR",$JOB,DFN,"V"),"^",3)))=$PIECE(^TMP("DGSSNAR",$JOB,DFN,"V"),"^")
SET DGTMPN1=1
+13 SET ^XTMP("DG-SSNRP2","DGPART1",("A"_$PIECE(^TMP("DGSSNAR",$JOB,DFN,"V"),"^",3)),DGSCTR)=$PIECE(^TMP("DGSSNAR",$JOB,DFN,"D",DGSCTR),"^",2)_"^"_DGDEPSSN_"^"_$PIECE(^TMP("DGSSNAR",$JOB,DFN,"D",DGSCTR),"^",3)
End DoDot:2
End DoDot:1
+14 QUIT
+15 ;
GETPART2 ;2nd part of report
+1 ;S ^XTMP("DG-SSNRP2","DGPART2",DGDEPSSN,DGCTR2)=DGDEPNM^DGDEPEL^DGVETSSN
+2 NEW DGSSN,DGSSND,DGSSNDA,DGSSN1,DGSSNCTR
+3 KILL ^TMP("DGSSNAR",$JOB)
+4 SET DGSSN=0
FOR
SET DGSSN=$ORDER(^DGPR(408.13,"SSN",DGSSN))
Begin DoDot:1
+5 if 'DGSSN
QUIT
+6 SET DGSSN1="A"_DGSSN
+7 SET (DGSSNDA,DGSSNCTR)=0
+8 FOR
SET DGSSNDA=$ORDER(^DGPR(408.13,"SSN",DGSSN,DGSSNDA))
Begin DoDot:2
+9 if 'DGSSNDA
QUIT
+10 SET DGSSND=$GET(^DGPR(408.13,DGSSNDA,0))
if DGSSND']""
QUIT
+11 ;^TMP("DGSSNAR",$J) array = IEN of INCOME PERSON file (#408.13)^dependent name
+12 SET DGSSNCTR=DGSSNCTR+1
+13 SET ^TMP("DGSSNAR",$JOB,DGSSN1,DGSSNCTR)=DGSSNDA_"^"_$PIECE(DGSSND,"^")
End DoDot:2
if 'DGSSNDA
QUIT
End DoDot:1
if 'DGSSN
QUIT
+14 ;
+15 DO SELPRT2
DO SDAM
DO SETTMP
+16 QUIT
+17 ;
SETTMP ; Spouse/dependent with the same SSN
+1 NEW DGSSNCTR,DGDEPNM,DGDEPREL,DGPAT,DGPATRL,DGSCTR,DGSSNDA1,DGVETSN2
+2 SET DGSSN=""
FOR
SET DGSSN=$ORDER(^TMP("DGSSNAR",$JOB,DGSSN))
if DGSSN=""
QUIT
Begin DoDot:1
+3 SET DGSSNCTR=+($ORDER(^TMP("DGSSNAR",$JOB,DGSSN,""),-1))
+4 FOR DGSCTR=1:1:DGSSNCTR
Begin DoDot:2
+5 SET DGSSNDA1=$PIECE(^TMP("DGSSNAR",$JOB,DGSSN,DGSCTR),"^")
+6 SET DGDEPNM=$PIECE(^TMP("DGSSNAR",$JOB,DGSSN,DGSCTR),"^",2)
+7 SET DGPAT=$ORDER(^DGPR(408.12,"C",DGSSNDA1_";DGPR(408.13,",0))
+8 SET DGPATRL=$GET(^DGPR(408.12,+DGPAT,0))
+9 ;missing "C" x-ref or 0 node of 408.12 record
+10 IF 'DGPATRL
SET DGDEPREL="U"
SET DGVETSN2="UNKNOWN"
+11 IF '$TEST
Begin DoDot:3
+12 SET DFN=+DGPATRL
+13 DO DEM^VADPT
+14 SET DGVETSN2=$PIECE($GET(VADM(2)),"^")
+15 SET DGDEPREL=$PIECE(DGPATRL,"^",2)
End DoDot:3
IF +DGVETSN2
if '$$OK2RPT(DFN)
QUIT
+16 SET ^XTMP("DG-SSNRP2","DGPART2",DGSSN,DGSCTR)=DGDEPNM_"^"_DGDEPREL_"^"_DGVETSN2
End DoDot:2
End DoDot:1
+17 QUIT
+18 ;
CHECKP1 ;if there is no part1 data S PART1D=0
+1 ;if data S PART1ST=1 indicating 1st time thru header
+2 IF '$DATA(^XTMP("DG-SSNRP2","DGPART1"))
SET PART1D=0
QUIT
+3 SET PART1ST=1
+4 QUIT
+5 ;
+1 if QUIT
QUIT
+2 NEW LINE
+3 IF $Y>1
WRITE @IOF
+4 WRITE !,?21,"Duplicate Spouse/Dependent SSN Report"
+5 WRITE ?70,"Page ",PAGE,!,?26,"Date Generated: "_$$FMTE^XLFDT(DT)
+6 SET PAGE=PAGE+1
+7 ;
+8 WRITE !,$SELECT(SECTION="PART1":" Spouse/Dependent with no SSN or the same SSN as Veteran",1:" Spouse/Dependent with the same SSN as another Spouse/Dependent")
+9 IF SECTION="PART1"
Begin DoDot:1
+10 IF 'PART1D
IF $DATA(^TMP($JOB,"SDAMA","ERR"))
WRITE !!,?10,"Appointment Database Unavailable to validate active veterans."
QUIT
+11 IF 'PART1D
WRITE !!,?25,"No entries meet this criteria"
QUIT
+12 IF 'PART1ST
DO PART1HD
QUIT
+13 SET PART1ST=0
End DoDot:1
+14 IF SECTION="PART2"
Begin DoDot:1
+15 WRITE !!
+16 IF 'PART2D
IF $DATA(^TMP($JOB,"SDAMA","ERR"))
WRITE !!,?10,"Appointment Database Unavailable to validate active veterans."
QUIT
+17 IF 'PART2D
WRITE ?25,"No entries meet this criteria"
QUIT
+18 WRITE "Spouse/Dependent Name",?33,"Spouse/Dependent SSN",?55,"Relationship",?69,"Veteran SSN"
End DoDot:1
+19 QUIT
+20 ;
PAUSE NEW DIR,DIRUT,X,Y
+1 FOR
if $Y>(IOSL-3)
QUIT
WRITE !
+2 SET DIR(0)="E"
DO ^DIR
+3 IF ('(+Y))!$DATA(DIRUT)
SET QUIT=1
+4 QUIT
+5 ;
PPART1 ;Description: Prints Part 1 - Spouse/Dependent with no SSN or the same SSN as Veteran
+1 NEW DGPART1,DGSCTR,LINE
SET DGVETSSN=0
+2 FOR
SET DGVETSSN=$ORDER(^XTMP("DG-SSNRP2","DGPART1",DGVETSSN))
if DGVETSSN']""
QUIT
Begin DoDot:1
+3 SET DGSCTR=0
SET DGVETNM=$GET(^XTMP("DG-SSNRP2","DGPART1",DGVETSSN))
+4 if QUIT
QUIT
DO PART1HEA
if QUIT
QUIT
+5 FOR
SET DGSCTR=$ORDER(^XTMP("DG-SSNRP2","DGPART1",DGVETSSN,DGSCTR))
if 'DGSCTR
QUIT
Begin DoDot:2
+6 SET DGPART1=$GET(^XTMP("DG-SSNRP2","DGPART1",DGVETSSN,DGSCTR))
+7 if DGPART1']""
QUIT
+8 SET LINE=$$LJ(" "_$PIECE(DGPART1,"^"),25)_" "_$$LJ($PIECE(DGPART1,"^",2),22)
+9 SET LINE=LINE_$$LJ($$RELCODE($PIECE(DGPART1,"^",3)),12)
+10 DO LINE(LINE)
if QUIT
QUIT
+11 if QUIT
QUIT
End DoDot:2
if QUIT
QUIT
+12 if QUIT
QUIT
End DoDot:1
if QUIT
QUIT
+13 QUIT
+14 ;
PPART2 ;Description: Prints Part 2 -Spouse/Dependent with the same SSN as another Spouse/Dependent
+1 NEW DGDEPSSN,DGPART2,DGP2F,DGSCTR,LINE
+2 SET DGP2F=1
SET DGDEPSSN=0
+3 FOR
SET DGDEPSSN=$ORDER(^XTMP("DG-SSNRP2","DGPART2",DGDEPSSN))
if DGDEPSSN']""
QUIT
Begin DoDot:1
+4 IF 'DGP2F
WRITE !
+5 IF '$TEST
SET DGP2F=0
+6 SET DGSCTR=0
+7 FOR
SET DGSCTR=$ORDER(^XTMP("DG-SSNRP2","DGPART2",DGDEPSSN,DGSCTR))
if 'DGSCTR
QUIT
Begin DoDot:2
+8 SET DGPART2=$GET(^XTMP("DG-SSNRP2","DGPART2",DGDEPSSN,DGSCTR))
+9 if DGPART2']""
QUIT
+10 SET LINE=$$LJ(" "_$PIECE(DGPART2,"^"),29)_" "_$$LJ($EXTRACT(DGDEPSSN,2,10),21)
+11 SET LINE=LINE_$$LJ($$RELCODE($PIECE(DGPART2,"^",2)),13)
+12 SET LINE=LINE_$$LJ(" "_$PIECE(DGPART2,"^",3),10)
+13 DO LINE(LINE)
if QUIT
QUIT
+14 if QUIT
QUIT
End DoDot:2
if QUIT
QUIT
+15 if QUIT
QUIT
End DoDot:1
if QUIT
QUIT
+16 QUIT
+17 ;
LJ(STRING,LENGTH) ;
+1 QUIT $$LJ^XLFSTR($EXTRACT(STRING,1,LENGTH),LENGTH)
+2 ;
RELCODE(DGCODE) ;returns relationship name from RELATIONSHIP file (#408.11)
+1 ;
+2 NEW DGNAME
SET DGNAME=$PIECE($GET(^DG(408.11,+DGCODE,0)),"^")
+3 IF DGNAME']""
QUIT "UNKNOWN"
+4 QUIT DGNAME
+5 ;
PART1HEA ;heading for part1 (vet name & SSN and spouse/dep name & SSN)
+1 IF ('CRT)
IF ($Y>(IOSL-6))
Begin DoDot:1
+2 DO HEADER
End DoDot:1
QUIT
+3 ;
+4 IF '$TEST
IF CRT
IF ($Y>(IOSL-8))
Begin DoDot:1
+5 DO PAUSE
+6 if QUIT
QUIT
+7 DO HEADER
End DoDot:1
if QUIT
QUIT
+8 ;
+9 IF '$TEST
DO PART1HD
+10 QUIT
+11 ;
PART1HD WRITE !!,"Veteran: ",$$LJ(DGVETNM,30)," Veteran SSN: ",$$LJ($EXTRACT(DGVETSSN,2,11),10),!!," Spouse/Dependent Name Spouse/Dependent SSN Relationship"
+1 QUIT
OKRPT(DFN,VADM) ; Date of Death?
+1 NEW X,X1,X2
+2 IF '$DATA(VADM)
DO DEM^VADPT
+3 IF +VADM(6)
QUIT 0
+4 QUIT 1
+5 ;
OKIMP(DFN) ; Inpatient or Outpatient in the last 3 years?
+1 NEW VAIP
SET VAIP("D")="LAST"
DO IN5^VADPT
+2 IF VAIP(3)'=""
Begin DoDot:1
+3 SET X1=DT
SET X2=$PIECE(VAIP(3),U)\1
DO ^%DTC
+4 IF X<1096
SET ^TMP($JOB,"SDAMA",DFN,+VAIP(3))="^^I;INPATIENT"
End DoDot:1
QUIT '(X>1095)
+5 QUIT 1
+6 ;
OK2RPT(DFN) ; Appt kept in the last 3 years?
+1 NEW APPCK,AFLG
SET (APPCK,AFLG)=0
+2 FOR
SET APPCK=$ORDER(^TMP($JOB,"SDAMA",DFN,APPCK))
if 'APPCK!(AFLG)
QUIT
Begin DoDot:1
+3 SET APPTYP=$PIECE($PIECE(^TMP($JOB,"SDAMA",DFN,APPCK),U,3),";")
+4 IF "^R^I^"[(U_APPTYP_U)
SET AFLG=1
End DoDot:1
+5 QUIT AFLG
+6 ;
VBLDARR(DFN) ; Build array of specified veterans
+1 SET ^TMP($JOB,"SDAMAPI",VARR)=$GET(^TMP($JOB,"SDAMAPI",VARR))_DFN_";"
+2 IF $LENGTH(^TMP($JOB,"SDAMAPI",VARR))>180
SET VARR=VARR+1
+3 QUIT
+4 ;
SDAM NEW DGARRAY,I,SDCNT
+1 SET DGARRAY(1)=$$FMADD^XLFDT(DT,-1095)_";"_DT
SET DGARRAY("FLDS")=3
SET DGARRAY("SORT")="P"
+2 FOR I=1:1
if '$DATA(^TMP($JOB,"SDAMAPI",I))
QUIT
Begin DoDot:1
+3 SET DGARRAY(4)=^TMP($JOB,"SDAMAPI",I)
+4 SET SDCNT=$$SDAPI^SDAMA301(.DGARRAY)
+5 IF SDCNT'>0
KILL ^TMP($JOB,"SDAMA301"),^TMP($JOB,"SDAMAPI",I)
QUIT
+6 MERGE ^TMP($JOB,"SDAMA")=^TMP($JOB,"SDAMA301")
+7 KILL ^TMP($JOB,"SDAMA301"),^TMP($JOB,"SDAMAPI",I)
End DoDot:1
+8 IF '$DATA(^TMP($JOB,"SDAMA"))
SET ^TMP($JOB,"SDAMA","ERR")=""
+9 QUIT
+10 ;
SELPRT2 ; Select records for Part 2
+1 NEW DGSSN,DGCNT,DGSSNP,DGPTR,DGPTRL,VARR
SET VARR=1
+2 SET DGSSN=""
FOR
SET DGSSN=$ORDER(^TMP("DGSSNAR",$JOB,DGSSN))
if DGSSN=""
QUIT
Begin DoDot:1
+3 SET DGCNT=$ORDER(^TMP("DGSSNAR",$JOB,DGSSN,""),-1)
+4 IF DGCNT<2
KILL ^TMP("DGSSNAR",$JOB,DGSSN)
QUIT
+5 SET DGSSNP=$PIECE(^TMP("DGSSNAR",$JOB,DGSSN,DGCNT),U)
+6 SET DGPTR=$ORDER(^DGPR(408.12,"C",DGSSNP_";DGPR(408.13,",0))
+7 SET DGPTRL=+$GET(^DGPR(408.12,+DGPTR,0))
+8 IF $$OKIMP(DGPTRL)
+9 if $DATA(^TMP($JOB,"SDAMA",DGPTRL))
QUIT
+10 DO VBLDARR(DGPTRL)
End DoDot:1
+11 QUIT
