- 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 Jan 18, 2025@03:59:41 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