DGPSEUDO ;ALB/ERC - REPORTS FOR PSEUDO SSN ; 1/17/06 9:58am
;;5.3;Registration;**653**;Aug 13, 1993;Build 2
;
;creates a report of all patients with pseudo SSNs
;can call for veteran, non-veterans or both
;can call for one Pseudo SSN Reason or can call for all reasons
;sorted by reason
TSK1 ;
N DGQUIT,DGREAS,DGREASON,DGTXT,DGQ,DGVET,DGXREAS,DGXVET
N ZTRTN,ZTDESC,ZTSK,ZTIO,ZTDTH,POP,IO,IOBS,IOF,IOHG,IOM,ION,IOPAR
N IOS,IOSL,IOST,IOT,IOUPAR,IOXY,%ZIS,ZTSAVE
K ^TMP("DGEVC",$J)
S DGQUIT=0
D QUESVET Q:DGQUIT
D QUESREAS Q:DGQUIT
S %ZIS="Q" D ^%ZIS I $G(POP) D ^%ZISC,HOME^%ZIS W !,"Job Terminated!" Q
I $D(IO("Q")) D Q
. S ZTRTN="RPT1^DGPSEUDO"
. S ZTDESC="PATIENTS WITH PSEUDO SOCIAL SECURITY NUMBERS"
. S (ZTSAVE("DGXREAS"),ZTSAVE("DGXVET"))=""
. D ^%ZTLOAD
. S DGTXT=$S($G(ZTSK):"Task: "_ZTSK_" Queued.",1:"Error: Process not queued!")
. W !,DGTXT
RPT1 ;
N DGC,DGPAGE,DGXXVET
S DGPAGE=0
S DGC=0
S DGXXVET=DGXVET
D LOOP1
D HDR1
I $G(DGC)'>0 W !!?25,"****NO RECORDS TO REPORT****" W ! D PAUSE Q
D REP1(DGXVET,DGXREAS)
D ^%ZISC,HOME^%ZIS
K ^TMP("DGEVC",$J)
Q
QUESVET ;ask user if report should be veterans, non-veterans, or both
N DGBOTH,DIR,DIRUT,DIROUT,X
W !!!,?10,"REPORT OF PATIENTS WITH PSEUDO SOCIAL SECURITY NUMBERS"
W !?5,"This report excludes deceased patients, non-user enrollees and"
W !?5,"with no Integration Control Numbers (ICN).",!
S DIR("A",1)="Do you want this report for Veterans, Non-Veterans or both?"
S DIR("A",2)="1. Veterans only"
S DIR("A",3)="2. Non-Veterans only"
S DIR("A",4)="3. Veterans and Non-Veterans"
S DIR("A")="Select"
S DIR("B")=1
S DIR("?")="Choose a report with Veterans only, Non-Veterans only or both."
S DIR(0)="N^1:3"
D ^DIR
I $D(DIRUT)!($D(DIROUT)) S DGQUIT=1
S DGXVET=$S(X=1:"VET",X=2:"NON",1:"BOTH")
Q
;
QUESREAS ;ask user which Pseudo SSN Reason, or all
N DIR,DIRUT,DIROUT,X
W !
S DIR("A",1)="Select which Pseudo SSN Reason(s) to be included in the report."
S DIR("A",2)="1. Refused to Provide"
S DIR("A",3)="2. SSN Unknown/Follow-up Required"
S DIR("A",4)="3. No SSN Assigned"
S DIR("A",5)="4. No reason on file"
S DIR("A",6)="5. All of the above"
S DIR("A")="Select"
S DIR("?")="Select one of the Reasons for having a Pseudo SSN."
S DIR(0)="N^1:5"
D ^DIR
I $D(DIRUT)!($D(DIROUT)) S DGQUIT=1
S DGXREAS=$S(X=1:"REFUSED TO PROVIDE",X=2:"SSN UNKNOWN/FOLLOW-UP REQUIRED",X=3:"NO SSN ASSIGNED",X=4:"NULL",1:"ALL")
Q
LOOP1 ;
I $E(IOST,1,2)["C-" U IO(0) W !!,"Scanning file...."
U IO
N DGDFN,DGX
K ^TMP("DGEVC",$J)
S ^TMP("DGEVC",$J,"COUNT","VET","REFUSED TO PROVIDE")=0
S ^TMP("DGEVC",$J,"COUNT","VET","SSN UNKNOWN/FOLLOW-UP REQUIRED")=0
S ^TMP("DGEVC",$J,"COUNT","VET","NO SSN ASSIGNED")=0
S ^TMP("DGEVC",$J,"COUNT","VET","NULL")=0
S ^TMP("DGEVC",$J,"COUNT","NON","REFUSED TO PROVIDE")=0
S ^TMP("DGEVC",$J,"COUNT","NON","SSN UNKNOWN/FOLLOW-UP REQUIRED")=0
S ^TMP("DGEVC",$J,"COUNT","NON","NO SSN ASSIGNED")=0
S ^TMP("DGEVC",$J,"COUNT","NON","NULL")=0
S DGX=999999999
F S DGX=$O(^DPT("SSN",DGX)) Q:DGX="" D
. I DGX'["P" Q
. S DGDFN=""
. F S DGDFN=$O(^DPT("SSN",DGX,DGDFN)) Q:'DGDFN D
. . I '$D(^DPT(DGDFN,0)) Q
. . D PSEU1
Q
PSEU1 ;
N DGARR,DGDOB,DGEC,DGERR,DGNAM,DGREASON,DGSSN,DGUSER,DGVET
I $D(^TMP("DGEVC",$J,DGDFN)) Q
D GETS^DIQ(2,DGDFN_",",".01;.03;.09;.0906;.351;.361;.3617;991.01;1901","EI","DGARR","DGERR")
I $D(DGERR) K DGERR Q
I $G(DGARR(2,DGDFN_",",.351,"I"))]"" K DGARR Q
I $G(DGARR(2,DGDFN_",",991.01,"I"))']"" K DGARR Q
S DGVET=$S($G(DGARR(2,DGDFN_",",1901,"I"))="Y":"VET",$G(DGARR(2,DGDFN_",",1901,"I"))="N":"NON",1:"NON")
I $G(DGVET)]"",DGXVET'="BOTH",DGVET'=DGXVET K DGARR Q
S DGREASON=$G(DGARR(2,DGDFN_",",.0906,"E"))
I $G(DGREASON)']"" S DGREASON="NULL"
I DGXREAS'="ALL",DGXREAS'=DGREASON K DGARR Q
S DGUSER=$G(DGARR(2,DGDFN_",",.3617,"I"))
I DGVET="YES",($G(DGUSER)']"") K DGARR Q
S DGUSER=$$FY($E(DGUSER,1,3)+1700)
I DGVET="VET",$G(DGUSER)'=1 K DGARR Q
S DGNAM=$G(DGARR(2,DGDFN_",",.01,"I"))
I $G(DGNAM)']"" K DGARR Q
S DGDOB=$G(DGARR(2,DGDFN_",",.03,"E"))
S DGEC=$G(DGARR(2,DGDFN_",",.361,"E"))
S DGSSN=DGARR(2,DGDFN_",",.09,"I")
I DGX'=DGSSN K DGARR Q
S DGC=DGC+1
S ^TMP("DGEVC",$J,DGVET,DGREASON,DGNAM,DGDFN)=$G(DGSSN)_"^"_$G(DGDOB)_"^"_$G(DGEC)
S ^TMP("DGEVC",$J,"COUNT")=DGC
S ^TMP("DGEVC",$J,"COUNT",DGVET,DGREASON)=$G(^TMP("DGEVC",$J,"COUNT",DGVET,DGREASON))+1
Q
FY(DGFY) ;determine if user enrollee date is current FY or later
N DGYEAR
S DGYEAR=$E(DT,1,3)+1700
I $E(DT,4,5)>9 S DGYEAR=DGYEAR+1
Q $S(DGFY>DGYEAR:1,DGFY=DGYEAR:1,1:0)
HDR1 ;
N DGDATE,DGL,DGLINE,DGT,Y ;display veteran, non-vet or both
I $E(IOST,1,2)["C-" W @IOF
S DGPAGE=DGPAGE+1
W !?((IOM-44)\2),"Patients with Pseudo Social Security Numbers",?70,"Page:"_DGPAGE
S DGT=$S(DGXXVET="VET":"Veterans only",DGXXVET="NON":"Non-Veterans only",1:"Veterans and Non-Veterans")
S DGT="Report shows "_DGT
S DGL=$L(DGT)
W !?((IOM-DGL)\2),DGT
S Y=DT X ^DD("DD") S DGDATE=Y
W !?62,"Date: "_$G(DGDATE)
W !!,"PATIENT",?32,"PSEUDO SSN",?44,"BIRTHDATE",?56,"PRIMARY ELIGIBILITY CODE"
N DGZ
W !
F DGZ=1:1:IOM W "-" ;S $P(DGLINE,"-",DGZ)=""
Q
REP1(DGXVET,DGXREAS) ;
N DGCT,DGV
S DGCT=0
I DGXVET="BOTH" D
. F DGV="VET","NON" D
. . Q:'$D(^TMP("DGEVC",$J,DGV))
. . Q:$G(DGQ)
. . I $E(IOST,1,2)["C-",($Y>(IOSL-4)) D PAUSE Q:$G(DGQ)
. . I $Y>(IOSL-4) D
. . . W @IOF
. . . D HDR1
. . W !!?5,"Report for "_$S(DGV="VET":"Veterans",1:"Non-Veterans")
. . D VET(DGV)
I DGXVET'="BOTH" D VET(DGXVET)
I $G(DGC)=DGCT W !!?29,"Patients with Pseudo SSNs: "_DGCT
I $E(IOST,1,2)["C-",('$G(DGQ)) W ! D PAUSE
Q
VET(DGXVET) ;
N DGR
I DGXREAS="ALL" D
. F DGR="REFUSED TO PROVIDE","SSN UNKNOWN/FOLLOW-UP REQUIRED","NO SSN ASSIGNED","NULL" D
. . Q:$G(DGQ)
. . D REAS(DGXVET,DGR)
I DGXREAS'="ALL" D
. D REAS(DGXVET,DGXREAS)
Q
REAS(DGXVET,DGXRR) ;
N DGN,DGNAM,DGDFN
S DGDFN=0
I $E(IOST,1,2)["C-",($Y>(IOSL-4)) D PAUSE Q:$G(DGQ)
I $Y>(IOSL-4) D
. W @IOF
. D HDR1
I $O(^TMP("DGEVC",$J,DGXVET,DGXRR,""))]"" W !!?10,"Pseudo SSN Reason: "_$S(DGXRR="NULL":"<NONE ENTERED>",1:DGXRR)
S DGNAM=""
F S DGNAM=$O(^TMP("DGEVC",$J,DGXVET,DGXRR,DGNAM)) Q:DGNAM']""!($G(DGQ)) D
. F S DGDFN=$O(^TMP("DGEVC",$J,DGXVET,DGXRR,DGNAM,DGDFN)) Q:DGDFN']""!($G(DGQ)) D
. . I $E(IOST,1,2)["C-",($Y>(IOSL-4)) D PAUSE Q:$G(DGQ)
. . I $Y>(IOSL-4) D
. . . W @IOF
. . . D HDR1
. . S DGN=^TMP("DGEVC",$J,DGXVET,DGXRR,DGNAM,DGDFN)
. . W !,DGNAM,?32,$P(DGN,U),?44,$P(DGN,U,2)
. . I $P(DGN,U,3)["SERVICE CONNECTED" S $P(DGN,U,3)="SC 50% TO 100%"
. . W ?56,$E($P(DGN,U,3),1,23)
. . S DGCT=$G(DGCT)+1
I ^TMP("DGEVC",$J,"COUNT",DGXVET,DGXRR)>0,(DGXREAS="ALL") W !?46,"Subtotal: "_^TMP("DGEVC",$J,"COUNT",DGXVET,DGXRR)
Q
;
PAUSE ;
N DIR,X,Y
S DGQ=0
S DIR(0)="E"
D ^DIR
I '+Y!($D(DIRUT)) S DGQ=1
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPSEUDO 6933 printed Oct 16, 2024@18:51:45 Page 2
DGPSEUDO ;ALB/ERC - REPORTS FOR PSEUDO SSN ; 1/17/06 9:58am
+1 ;;5.3;Registration;**653**;Aug 13, 1993;Build 2
+2 ;
+3 ;creates a report of all patients with pseudo SSNs
+4 ;can call for veteran, non-veterans or both
+5 ;can call for one Pseudo SSN Reason or can call for all reasons
+6 ;sorted by reason
TSK1 ;
+1 NEW DGQUIT,DGREAS,DGREASON,DGTXT,DGQ,DGVET,DGXREAS,DGXVET
+2 NEW ZTRTN,ZTDESC,ZTSK,ZTIO,ZTDTH,POP,IO,IOBS,IOF,IOHG,IOM,ION,IOPAR
+3 NEW IOS,IOSL,IOST,IOT,IOUPAR,IOXY,%ZIS,ZTSAVE
+4 KILL ^TMP("DGEVC",$JOB)
+5 SET DGQUIT=0
+6 DO QUESVET
if DGQUIT
QUIT
+7 DO QUESREAS
if DGQUIT
QUIT
+8 SET %ZIS="Q"
DO ^%ZIS
IF $GET(POP)
DO ^%ZISC
DO HOME^%ZIS
WRITE !,"Job Terminated!"
QUIT
+9 IF $DATA(IO("Q"))
Begin DoDot:1
+10 SET ZTRTN="RPT1^DGPSEUDO"
+11 SET ZTDESC="PATIENTS WITH PSEUDO SOCIAL SECURITY NUMBERS"
+12 SET (ZTSAVE("DGXREAS"),ZTSAVE("DGXVET"))=""
+13 DO ^%ZTLOAD
+14 SET DGTXT=$SELECT($GET(ZTSK):"Task: "_ZTSK_" Queued.",1:"Error: Process not queued!")
+15 WRITE !,DGTXT
End DoDot:1
QUIT
RPT1 ;
+1 NEW DGC,DGPAGE,DGXXVET
+2 SET DGPAGE=0
+3 SET DGC=0
+4 SET DGXXVET=DGXVET
+5 DO LOOP1
+6 DO HDR1
+7 IF $GET(DGC)'>0
WRITE !!?25,"****NO RECORDS TO REPORT****"
WRITE !
DO PAUSE
QUIT
+8 DO REP1(DGXVET,DGXREAS)
+9 DO ^%ZISC
DO HOME^%ZIS
+10 KILL ^TMP("DGEVC",$JOB)
+11 QUIT
QUESVET ;ask user if report should be veterans, non-veterans, or both
+1 NEW DGBOTH,DIR,DIRUT,DIROUT,X
+2 WRITE !!!,?10,"REPORT OF PATIENTS WITH PSEUDO SOCIAL SECURITY NUMBERS"
+3 WRITE !?5,"This report excludes deceased patients, non-user enrollees and"
+4 WRITE !?5,"with no Integration Control Numbers (ICN).",!
+5 SET DIR("A",1)="Do you want this report for Veterans, Non-Veterans or both?"
+6 SET DIR("A",2)="1. Veterans only"
+7 SET DIR("A",3)="2. Non-Veterans only"
+8 SET DIR("A",4)="3. Veterans and Non-Veterans"
+9 SET DIR("A")="Select"
+10 SET DIR("B")=1
+11 SET DIR("?")="Choose a report with Veterans only, Non-Veterans only or both."
+12 SET DIR(0)="N^1:3"
+13 DO ^DIR
+14 IF $DATA(DIRUT)!($DATA(DIROUT))
SET DGQUIT=1
+15 SET DGXVET=$SELECT(X=1:"VET",X=2:"NON",1:"BOTH")
+16 QUIT
+17 ;
QUESREAS ;ask user which Pseudo SSN Reason, or all
+1 NEW DIR,DIRUT,DIROUT,X
+2 WRITE !
+3 SET DIR("A",1)="Select which Pseudo SSN Reason(s) to be included in the report."
+4 SET DIR("A",2)="1. Refused to Provide"
+5 SET DIR("A",3)="2. SSN Unknown/Follow-up Required"
+6 SET DIR("A",4)="3. No SSN Assigned"
+7 SET DIR("A",5)="4. No reason on file"
+8 SET DIR("A",6)="5. All of the above"
+9 SET DIR("A")="Select"
+10 SET DIR("?")="Select one of the Reasons for having a Pseudo SSN."
+11 SET DIR(0)="N^1:5"
+12 DO ^DIR
+13 IF $DATA(DIRUT)!($DATA(DIROUT))
SET DGQUIT=1
+14 SET DGXREAS=$SELECT(X=1:"REFUSED TO PROVIDE",X=2:"SSN UNKNOWN/FOLLOW-UP REQUIRED",X=3:"NO SSN ASSIGNED",X=4:"NULL",1:"ALL")
+15 QUIT
LOOP1 ;
+1 IF $EXTRACT(IOST,1,2)["C-"
USE IO(0)
WRITE !!,"Scanning file...."
+2 USE IO
+3 NEW DGDFN,DGX
+4 KILL ^TMP("DGEVC",$JOB)
+5 SET ^TMP("DGEVC",$JOB,"COUNT","VET","REFUSED TO PROVIDE")=0
+6 SET ^TMP("DGEVC",$JOB,"COUNT","VET","SSN UNKNOWN/FOLLOW-UP REQUIRED")=0
+7 SET ^TMP("DGEVC",$JOB,"COUNT","VET","NO SSN ASSIGNED")=0
+8 SET ^TMP("DGEVC",$JOB,"COUNT","VET","NULL")=0
+9 SET ^TMP("DGEVC",$JOB,"COUNT","NON","REFUSED TO PROVIDE")=0
+10 SET ^TMP("DGEVC",$JOB,"COUNT","NON","SSN UNKNOWN/FOLLOW-UP REQUIRED")=0
+11 SET ^TMP("DGEVC",$JOB,"COUNT","NON","NO SSN ASSIGNED")=0
+12 SET ^TMP("DGEVC",$JOB,"COUNT","NON","NULL")=0
+13 SET DGX=999999999
+14 FOR
SET DGX=$ORDER(^DPT("SSN",DGX))
if DGX=""
QUIT
Begin DoDot:1
+15 IF DGX'["P"
QUIT
+16 SET DGDFN=""
+17 FOR
SET DGDFN=$ORDER(^DPT("SSN",DGX,DGDFN))
if 'DGDFN
QUIT
Begin DoDot:2
+18 IF '$DATA(^DPT(DGDFN,0))
QUIT
+19 DO PSEU1
End DoDot:2
End DoDot:1
+20 QUIT
PSEU1 ;
+1 NEW DGARR,DGDOB,DGEC,DGERR,DGNAM,DGREASON,DGSSN,DGUSER,DGVET
+2 IF $DATA(^TMP("DGEVC",$JOB,DGDFN))
QUIT
+3 DO GETS^DIQ(2,DGDFN_",",".01;.03;.09;.0906;.351;.361;.3617;991.01;1901","EI","DGARR","DGERR")
+4 IF $DATA(DGERR)
KILL DGERR
QUIT
+5 IF $GET(DGARR(2,DGDFN_",",.351,"I"))]""
KILL DGARR
QUIT
+6 IF $GET(DGARR(2,DGDFN_",",991.01,"I"))']""
KILL DGARR
QUIT
+7 SET DGVET=$SELECT($GET(DGARR(2,DGDFN_",",1901,"I"))="Y":"VET",$GET(DGARR(2,DGDFN_",",1901,"I"))="N":"NON",1:"NON")
+8 IF $GET(DGVET)]""
IF DGXVET'="BOTH"
IF DGVET'=DGXVET
KILL DGARR
QUIT
+9 SET DGREASON=$GET(DGARR(2,DGDFN_",",.0906,"E"))
+10 IF $GET(DGREASON)']""
SET DGREASON="NULL"
+11 IF DGXREAS'="ALL"
IF DGXREAS'=DGREASON
KILL DGARR
QUIT
+12 SET DGUSER=$GET(DGARR(2,DGDFN_",",.3617,"I"))
+13 IF DGVET="YES"
IF ($GET(DGUSER)']"")
KILL DGARR
QUIT
+14 SET DGUSER=$$FY($EXTRACT(DGUSER,1,3)+1700)
+15 IF DGVET="VET"
IF $GET(DGUSER)'=1
KILL DGARR
QUIT
+16 SET DGNAM=$GET(DGARR(2,DGDFN_",",.01,"I"))
+17 IF $GET(DGNAM)']""
KILL DGARR
QUIT
+18 SET DGDOB=$GET(DGARR(2,DGDFN_",",.03,"E"))
+19 SET DGEC=$GET(DGARR(2,DGDFN_",",.361,"E"))
+20 SET DGSSN=DGARR(2,DGDFN_",",.09,"I")
+21 IF DGX'=DGSSN
KILL DGARR
QUIT
+22 SET DGC=DGC+1
+23 SET ^TMP("DGEVC",$JOB,DGVET,DGREASON,DGNAM,DGDFN)=$GET(DGSSN)_"^"_$GET(DGDOB)_"^"_$GET(DGEC)
+24 SET ^TMP("DGEVC",$JOB,"COUNT")=DGC
+25 SET ^TMP("DGEVC",$JOB,"COUNT",DGVET,DGREASON)=$GET(^TMP("DGEVC",$JOB,"COUNT",DGVET,DGREASON))+1
+26 QUIT
FY(DGFY) ;determine if user enrollee date is current FY or later
+1 NEW DGYEAR
+2 SET DGYEAR=$EXTRACT(DT,1,3)+1700
+3 IF $EXTRACT(DT,4,5)>9
SET DGYEAR=DGYEAR+1
+4 QUIT $SELECT(DGFY>DGYEAR:1,DGFY=DGYEAR:1,1:0)
HDR1 ;
+1 ;display veteran, non-vet or both
NEW DGDATE,DGL,DGLINE,DGT,Y
+2 IF $EXTRACT(IOST,1,2)["C-"
WRITE @IOF
+3 SET DGPAGE=DGPAGE+1
+4 WRITE !?((IOM-44)\2),"Patients with Pseudo Social Security Numbers",?70,"Page:"_DGPAGE
+5 SET DGT=$SELECT(DGXXVET="VET":"Veterans only",DGXXVET="NON":"Non-Veterans only",1:"Veterans and Non-Veterans")
+6 SET DGT="Report shows "_DGT
+7 SET DGL=$LENGTH(DGT)
+8 WRITE !?((IOM-DGL)\2),DGT
+9 SET Y=DT
XECUTE ^DD("DD")
SET DGDATE=Y
+10 WRITE !?62,"Date: "_$GET(DGDATE)
+11 WRITE !!,"PATIENT",?32,"PSEUDO SSN",?44,"BIRTHDATE",?56,"PRIMARY ELIGIBILITY CODE"
+12 NEW DGZ
+13 WRITE !
+14 ;S $P(DGLINE,"-",DGZ)=""
FOR DGZ=1:1:IOM
WRITE "-"
+15 QUIT
REP1(DGXVET,DGXREAS) ;
+1 NEW DGCT,DGV
+2 SET DGCT=0
+3 IF DGXVET="BOTH"
Begin DoDot:1
+4 FOR DGV="VET","NON"
Begin DoDot:2
+5 if '$DATA(^TMP("DGEVC",$JOB,DGV))
QUIT
+6 if $GET(DGQ)
QUIT
+7 IF $EXTRACT(IOST,1,2)["C-"
IF ($Y>(IOSL-4))
DO PAUSE
if $GET(DGQ)
QUIT
+8 IF $Y>(IOSL-4)
Begin DoDot:3
+9 WRITE @IOF
+10 DO HDR1
End DoDot:3
+11 WRITE !!?5,"Report for "_$SELECT(DGV="VET":"Veterans",1:"Non-Veterans")
+12 DO VET(DGV)
End DoDot:2
End DoDot:1
+13 IF DGXVET'="BOTH"
DO VET(DGXVET)
+14 IF $GET(DGC)=DGCT
WRITE !!?29,"Patients with Pseudo SSNs: "_DGCT
+15 IF $EXTRACT(IOST,1,2)["C-"
IF ('$GET(DGQ))
WRITE !
DO PAUSE
+16 QUIT
VET(DGXVET) ;
+1 NEW DGR
+2 IF DGXREAS="ALL"
Begin DoDot:1
+3 FOR DGR="REFUSED TO PROVIDE","SSN UNKNOWN/FOLLOW-UP REQUIRED","NO SSN ASSIGNED","NULL"
Begin DoDot:2
+4 if $GET(DGQ)
QUIT
+5 DO REAS(DGXVET,DGR)
End DoDot:2
End DoDot:1
+6 IF DGXREAS'="ALL"
Begin DoDot:1
+7 DO REAS(DGXVET,DGXREAS)
End DoDot:1
+8 QUIT
REAS(DGXVET,DGXRR) ;
+1 NEW DGN,DGNAM,DGDFN
+2 SET DGDFN=0
+3 IF $EXTRACT(IOST,1,2)["C-"
IF ($Y>(IOSL-4))
DO PAUSE
if $GET(DGQ)
QUIT
+4 IF $Y>(IOSL-4)
Begin DoDot:1
+5 WRITE @IOF
+6 DO HDR1
End DoDot:1
+7 IF $ORDER(^TMP("DGEVC",$JOB,DGXVET,DGXRR,""))]""
WRITE !!?10,"Pseudo SSN Reason: "_$SELECT(DGXRR="NULL":"<NONE ENTERED>",1:DGXRR)
+8 SET DGNAM=""
+9 FOR
SET DGNAM=$ORDER(^TMP("DGEVC",$JOB,DGXVET,DGXRR,DGNAM))
if DGNAM']""!($GET(DGQ))
QUIT
Begin DoDot:1
+10 FOR
SET DGDFN=$ORDER(^TMP("DGEVC",$JOB,DGXVET,DGXRR,DGNAM,DGDFN))
if DGDFN']""!($GET(DGQ))
QUIT
Begin DoDot:2
+11 IF $EXTRACT(IOST,1,2)["C-"
IF ($Y>(IOSL-4))
DO PAUSE
if $GET(DGQ)
QUIT
+12 IF $Y>(IOSL-4)
Begin DoDot:3
+13 WRITE @IOF
+14 DO HDR1
End DoDot:3
+15 SET DGN=^TMP("DGEVC",$JOB,DGXVET,DGXRR,DGNAM,DGDFN)
+16 WRITE !,DGNAM,?32,$PIECE(DGN,U),?44,$PIECE(DGN,U,2)
+17 IF $PIECE(DGN,U,3)["SERVICE CONNECTED"
SET $PIECE(DGN,U,3)="SC 50% TO 100%"
+18 WRITE ?56,$EXTRACT($PIECE(DGN,U,3),1,23)
+19 SET DGCT=$GET(DGCT)+1
End DoDot:2
End DoDot:1
+20 IF ^TMP("DGEVC",$JOB,"COUNT",DGXVET,DGXRR)>0
IF (DGXREAS="ALL")
WRITE !?46,"Subtotal: "_^TMP("DGEVC",$JOB,"COUNT",DGXVET,DGXRR)
+21 QUIT
+22 ;
PAUSE ;
+1 NEW DIR,X,Y
+2 SET DGQ=0
+3 SET DIR(0)="E"
+4 DO ^DIR
+5 IF '+Y!($DATA(DIRUT))
SET DGQ=1
+6 QUIT
+7 ;
