AGLSSN ; IHS/ASDS/EFG - LISTING OF PATIENTS W/O SSN ;
;;7.1;PATIENT REGISTRATION;;AUG 25,2005
;
;This routine will go through VA Patient file, looking for people with
;no SSN
;
PTS ;
S DIR(0)="Y"
S DIR("A",1)="Unless specified, ONLY ACTIVE PATIENTS will be included."
S DIR("A")="Do you want to include inactive/deceased patients?"
S DIR("B")="N"
D ^DIR K DIR
S AGPTS=Y
Q:$D(DUOUT)!$D(DTOUT)!$D(DFOUT)
;
W1 W !!! S %ZIS="Q",%ZIS("B")="" D ^%ZIS G:'$D(IO)!(POP) QUIT
S AG("ION")=ION G:$D(IO("Q")) QUE G PROC
PRQUE ;ENTER FROM TASK MANAGER
PROC ;
K ^TMP($J)
S AGBM=IOSL-10
D NOW^%DTC
S Y=X
D DD^%DT
S AGDATE=Y
S D0=0
F S D0=$O(^DPT(D0)) Q:D0="" D
.;check active/inactive/deleted
.S AGNONACT=$P($G(^AUPNPAT(D0,41,DUZ(2),0)),U,3)
.S AGDEC=$P($G(^DPT(D0,.35)),U)
.I AGPTS="0",$G(AGNONACT)'=""!($G(AGDEC)'="") Q
.;check for ssn
.S AGSSN=+$P($G(^DPT(D0,0)),U,9)
.I $G(AGSSN)=0 D
..S AGREASON=$P($G(^AUPNPAT(D0,0)),U,24)
..S AGNAME=$P($G(^DPT(D0,0)),U)
..S AGDOB=$P($G(^DPT(D0,0)),U,3)
..S AGHRN=$P($G(^AUPNPAT(D0,41,DUZ(2),0)),U,2)
..Q:AGHRN=""
..S:AGDOB="" AGDOB="NONE"
..S AGREASON=$S(AGREASON=1:"NOT AVAILABLE",AGREASON=2:"PATIENT REFUSED",AGREASON=3:"PATIENT WILL SUBMIT",1:"REASON FOR NO SSN NOT YET ENTERED")
..Q:AGNAME=""
..S ^TMP($J,AGREASON,AGNAME,AGHRN,AGDOB)=""
WRITE ;
K AGRECS
S AGPAGE=1
S AGRECS=0
S AGFLAG=0
D HDR
S (AGREASON,AGNAME,AGHRN,AGDOB,AGEND)=""
F S AGREASON=$O(^TMP($J,AGREASON)) Q:AGREASON="" D Q:AGEND
.F S AGNAME=$O(^TMP($J,AGREASON,AGNAME)) Q:AGNAME="" D Q:AGEND
..F S AGHRN=$O(^TMP($J,AGREASON,AGNAME,AGHRN)) Q:AGHRN="" D Q:AGEND
...F S AGDOB=$O(^TMP($J,AGREASON,AGNAME,AGHRN,AGDOB)) Q:AGDOB="" D Q:AGEND
....S AGR=AGREASON
....S Y=AGDOB
....D DD^%DT
....S AGD=Y
....W !,AGR,?35,AGNAME,?59,AGHRN,?67,AGD
....S AGRECS=AGRECS+1
....I $Y>AGBM D
.....D RTRN^AG
.....I $D(DUOUT)!$D(DTOUT)!$D(DTOUT) S AGEND=1 G END
.....D HDR
I 'AGEND D END
Q
HDR U IO I IOST["C" W $$S^AGVDF("IOF")
D CPI^AG ;Conf. patient info thing
W !,?64,AGDATE
W !,?5,$P(^AUTTLOC(DUZ(2),0),U,2),?27,"LISTING OF PATIENTS W/O SSN",?70,"PAGE ",AGPAGE
W !,"REASON FOR NO SSN",?35,"NAME",?59,"HRN",?67,"DOB",!
F X=1:1:80 W "="
S AGPAGE=AGPAGE+1
Q
END ;
W !!,"TOTAL PEOPLE LACKING SSN: ",AGRECS
K ^TMP($J)
K AGREASON,AGNAME,AGHRN,AGDOB
K AGSSN,D0,AGPTS,AGRECS
K AGBM,AGD,AGDATE,AGDEC,AGFLAG,AGIEN,AGMVDF,AGNONACT,AGPAGE,AGR
QUIT D ^%ZISC K AG
Q
QUE K IO("Q") S ZTRTN="PRQUE^AGLSSN",ZTDESC="LISTING OF PATIENTS W/O SSN-QUE" F AG="AG(""ION"")" S ZTSAVE("AG*")=""
D ^%ZTLOAD W:$D(ZTSK) !,"REQUEST QUEUED!",!,"#",ZTSK G QUIT
AGLSSN ; IHS/ASDS/EFG - LISTING OF PATIENTS W/O SSN ;
+1 ;;7.1;PATIENT REGISTRATION;;AUG 25,2005
+2 ;
+3 ;This routine will go through VA Patient file, looking for people with
+4 ;no SSN
+5 ;
PTS ;
+1 SET DIR(0)="Y"
+2 SET DIR("A",1)="Unless specified, ONLY ACTIVE PATIENTS will be included."
+3 SET DIR("A")="Do you want to include inactive/deceased patients?"
+4 SET DIR("B")="N"
+5 DO ^DIR
KILL DIR
+6 SET AGPTS=Y
+7 IF $DATA(DUOUT)!$DATA(DTOUT)!$DATA(DFOUT)
QUIT
+8 ;
W1 WRITE !!!
SET %ZIS="Q"
SET %ZIS("B")=""
DO ^%ZIS
IF '$DATA(IO)!(POP)
GOTO QUIT
+1 SET AG("ION")=ION
IF $DATA(IO("Q"))
GOTO QUE
GOTO PROC
PRQUE ;ENTER FROM TASK MANAGER
PROC ;
+1 KILL ^TMP($JOB)
+2 SET AGBM=IOSL-10
+3 DO NOW^%DTC
+4 SET Y=X
+5 DO DD^%DT
+6 SET AGDATE=Y
+7 SET D0=0
+8 FOR
SET D0=$ORDER(^DPT(D0))
IF D0=""
QUIT
Begin DoDot:1
+9 ;check active/inactive/deleted
+10 SET AGNONACT=$PIECE($GET(^AUPNPAT(D0,41,DUZ(2),0)),U,3)
+11 SET AGDEC=$PIECE($GET(^DPT(D0,.35)),U)
+12 IF AGPTS="0"
IF $GET(AGNONACT)'=""!($GET(AGDEC)'="")
QUIT
+13 ;check for ssn
+14 SET AGSSN=+$PIECE($GET(^DPT(D0,0)),U,9)
+15 IF $GET(AGSSN)=0
Begin DoDot:2
+16 SET AGREASON=$PIECE($GET(^AUPNPAT(D0,0)),U,24)
+17 SET AGNAME=$PIECE($GET(^DPT(D0,0)),U)
+18 SET AGDOB=$PIECE($GET(^DPT(D0,0)),U,3)
+19 SET AGHRN=$PIECE($GET(^AUPNPAT(D0,41,DUZ(2),0)),U,2)
+20 IF AGHRN=""
QUIT
+21 IF AGDOB=""
SET AGDOB="NONE"
+22 SET AGREASON=$SELECT(AGREASON=1:"NOT AVAILABLE",AGREASON=2:"PATIENT REFUSED",AGREASON=3:"PATIENT WILL SUBMIT",1:"REASON FOR NO SSN NOT YET ENTERED")
+23 IF AGNAME=""
QUIT
+24 SET ^TMP($JOB,AGREASON,AGNAME,AGHRN,AGDOB)=""
End DoDot:2
End DoDot:1
WRITE ;
+1 KILL AGRECS
+2 SET AGPAGE=1
+3 SET AGRECS=0
+4 SET AGFLAG=0
+5 DO HDR
+6 SET (AGREASON,AGNAME,AGHRN,AGDOB,AGEND)=""
+7 FOR
SET AGREASON=$ORDER(^TMP($JOB,AGREASON))
IF AGREASON=""
QUIT
Begin DoDot:1
+8 FOR
SET AGNAME=$ORDER(^TMP($JOB,AGREASON,AGNAME))
IF AGNAME=""
QUIT
Begin DoDot:2
+9 FOR
SET AGHRN=$ORDER(^TMP($JOB,AGREASON,AGNAME,AGHRN))
IF AGHRN=""
QUIT
Begin DoDot:3
+10 FOR
SET AGDOB=$ORDER(^TMP($JOB,AGREASON,AGNAME,AGHRN,AGDOB))
IF AGDOB=""
QUIT
Begin DoDot:4
+11 SET AGR=AGREASON
+12 SET Y=AGDOB
+13 DO DD^%DT
+14 SET AGD=Y
+15 WRITE !,AGR,?35,AGNAME,?59,AGHRN,?67,AGD
+16 SET AGRECS=AGRECS+1
+17 IF $Y>AGBM
Begin DoDot:5
+18 DO RTRN^AG
+19 IF $DATA(DUOUT)!$DATA(DTOUT)!$DATA(DTOUT)
SET AGEND=1
GOTO END
+20 DO HDR
End DoDot:5
End DoDot:4
IF AGEND
QUIT
End DoDot:3
IF AGEND
QUIT
End DoDot:2
IF AGEND
QUIT
End DoDot:1
IF AGEND
QUIT
+21 IF 'AGEND
DO END
+22 QUIT
HDR USE IO
IF IOST["C"
WRITE $$S^AGVDF("IOF")
+1 ;Conf. patient info thing
DO CPI^AG
+2 WRITE !,?64,AGDATE
+3 WRITE !,?5,$PIECE(^AUTTLOC(DUZ(2),0),U,2),?27,"LISTING OF PATIENTS W/O SSN",?70,"PAGE ",AGPAGE
+4 WRITE !,"REASON FOR NO SSN",?35,"NAME",?59,"HRN",?67,"DOB",!
+5 FOR X=1:1:80
WRITE "="
+6 SET AGPAGE=AGPAGE+1
+7 QUIT
END ;
+1 WRITE !!,"TOTAL PEOPLE LACKING SSN: ",AGRECS
+2 KILL ^TMP($JOB)
+3 KILL AGREASON,AGNAME,AGHRN,AGDOB
+4 KILL AGSSN,D0,AGPTS,AGRECS
+5 KILL AGBM,AGD,AGDATE,AGDEC,AGFLAG,AGIEN,AGMVDF,AGNONACT,AGPAGE,AGR
QUIT DO ^%ZISC
KILL AG
+1 QUIT
QUE KILL IO("Q")
SET ZTRTN="PRQUE^AGLSSN"
SET ZTDESC="LISTING OF PATIENTS W/O SSN-QUE"
FOR AG="AG(""ION"")"
SET ZTSAVE("AG*")=""
+1 DO ^%ZTLOAD
IF $DATA(ZTSK)
WRITE !,"REQUEST QUEUED!",!,"#",ZTSK
GOTO QUIT
