AGRPTVET ; IHS/ASDS/EFG - ALPHA LIST OF ALL VETERANS IN DATA BASE ;
;;7.1;PATIENT REGISTRATION;**2,4**;JAN 31, 2007
S AGIO=IO,AG("HAT")=""
DEV S %ZIS="OPQ" D ^%ZIS I POP S IOP=ION D ^%ZIS Q
G:'$D(IO("Q")) START K IO("Q") I $D(IO("S"))!($E(IOST)'="P") W *7,!,"Please queue to system printers." D ^%ZISC G DEV
X ^%ZOSF("UCI") S ZTRTN="START^AGRPTVET",ZTUCI=Y,ZTIO="",ZTDESC="ALPHA LIST OF ALL VETERANS for "_$P(^AUTTLOC(DUZ(2),0),U,2)_".",AGQIO=IO F G="AGQIO","DUZ" S ZTSAVE(G)=""
D ^%ZTLOAD G:'$D(ZTSK) DEV K AG,AGIO,AGQIO,G,ZTDESC,ZTIO,ZTRTN,ZTSK,ZTUCI D ^%ZISC
Q
START ;EP - From TaskMan.
K ^TMP($J)
;S N="" F I=0:0 S N=$O(^DPT("B",N)) Q:N="" F DFN=0:0 S DFN=$O(^DPT("B",N,DFN)) Q:'DFN I $D(^DPT(DFN,0)),$P(^DPT(DFN,0),U)=N,$D(^DPT(DFN,"VET")) S ^TMP($J,$P(^DPT(DFN,0),U),DFN)=""
S N="" F I=0:0 S N=$O(^DPT("B",N)) Q:N="" F DFN=0:0 S DFN=$O(^DPT("B",N,DFN)) Q:'DFN I $D(^DPT(DFN,0)),$P(^DPT(DFN,0),U)=N,$D(^DPT(DFN,"VET")) Q:$P($G(^DPT(DFN,"VET")),U)'="Y" S ^TMP($J,$P(^DPT(DFN,0),U),DFN)="" ;IM22907 AG*7.1*2
I $D(AGQIO) F AGZ("I")=1:1 S IOP=AGQIO D ^%ZIS Q:'POP H 30
S AGEL("DFN")="",(AGPGPG,N,T)=0,X=$P(^DIC(4,DUZ(2),0),U) D CTR^AG S AG("LOC")=X,AG("USR")=$P(^VA(200,DUZ,0),U),AGBM=IOSL-10 I $D(AGIO),AGIO=IO S AGBM=IOSL-4
X ^%ZOSF("UCI") S X="UCI: "_$P(Y,",") D CTR^AG S AGUCI=X
U IO D NOW^AG S X="as of "_AGTIME D CTR^AG S AGTIME=X D HDR
L1 S AGEL("DFN")=$O(^TMP($J,AGEL("DFN"))) G END:AGEL("DFN")="" S DFN=$O(^TMP($J,AGEL("DFN"),""))
K ^UTILITY("DIQ1",$J)
K DIC,DA,DR,DIQ ;AG*7.1*2 FOUND DURING TESTING - NOT PRINTING SSN/DOB BECAUSE DIQ QWAS SET FROM USER ENTERING 'EPT' OPTION
W !,$P(^DPT(DFN,0),U) S DIC=2,DA=DFN,DR=.313 D EN^DIQ1 W:$D(^(DR)) " (",^(DR),")"
S AG="" I $D(^AUPNPAT(DFN,41,DUZ(2),0)) S:$P(^AUPNPAT(DFN,41,DUZ(2),0),U,3)]"" AG="*"
D DEAD^AGMAN S AG=AG_$S($D(AG("DEAD")):"D",1:"") W:AG]"" " (",AG,")"
;S DIC=2,DR=.09,DA=DFN D EN^DIQ1 W:$D(^(DR)) ?52,^(DR) S DR=.03 D EN^DIQ1 W:$D(^(DR)) ?66,$J(^(DR),10)
W ?52,$$GET1^DIQ(9000001,DFN_",",1107.3) S DIC=2,DA=DFN,DR=.03 D EN^DIQ1 W:$D(^(DR)) ?66,$J(^(DR),10) ;IHS/SD/TPF AG*7.1*4
F AG=1:1 S DIC=9000001.41,DA=DFN,AG("DRENT")=AG,DR=.02 D ^AGDICLK Q:$D(AG("LKERR"))!($G(AG("QUIT"))) D
.W !?20,$J(AG("LKPRINT"),6)
.S AG("DRENT")=AG,DR=.01 D ^AGDICLK W:'$D(AG("LKERR")) ?30,$P(^DIC(4,AG("LKPRINT"),0),U)
.I $Y>AGBM D RTRN^AG I $D(DUOUT)!($D(DTOUT))!($D(DFOUT)) S AG("QUIT")=1 Q
.I $Y>AGBM D HDR
I $G(AG("QUIT")) G END1
S T=T+1 I $Y>AGBM D RTRN^AG G:$D(DUOUT)!$D(DTOUT)!$D(DFOUT) END1 D HDR
G L1
END W !!,"Total Patients: ",T K AG("HAT") D RTRN^AG W $$S^AGVDF("IOF")
END1 D ^%ZISC K AG,AGIO,AGQIO,AGTIME,AGBM,DA,AG("DENT"),DIC,DR,G,AGL,AG("LKDATA"),AG("LKERR"),AG("LKPRINT"),AG("LOC"),N,AGPCC,AGPGPG,T,AGUCI,AG("USR"),X,Y,^TMP($J) D:$D(ZTQUEUED) KILL^%ZTLOAD
Q
HDR S AGPGPG=AGPGPG+1,AG("LINE")="="
W $$S^AGVDF("IOF"),!!,AG("USR"),?72,"page ",AGPGPG,!,AG("LOC"),!?23,"ALL VETERANS - ALPHABETICAL LISTING",!,AGUCI,!?24,"('*' = INACTIVE), ('D' = DECEASED)",!,AGTIME,!!!?3,"Name (claim #)",?21,"IHS #",?30,"FACILITY",?56,"SSN",?70,"DOB" D LINE^AG
Q
AGRPTVET ; IHS/ASDS/EFG - ALPHA LIST OF ALL VETERANS IN DATA BASE ;
+1 ;;7.1;PATIENT REGISTRATION;**2,4**;JAN 31, 2007
+2 SET AGIO=IO
SET AG("HAT")=""
DEV SET %ZIS="OPQ"
DO ^%ZIS
IF POP
SET IOP=ION
DO ^%ZIS
QUIT
+1 IF '$DATA(IO("Q"))
GOTO START
KILL IO("Q")
IF $DATA(IO("S"))!($EXTRACT(IOST)'="P")
WRITE *7,!,"Please queue to system printers."
DO ^%ZISC
GOTO DEV
+2 XECUTE ^%ZOSF("UCI")
SET ZTRTN="START^AGRPTVET"
SET ZTUCI=Y
SET ZTIO=""
SET ZTDESC="ALPHA LIST OF ALL VETERANS for "_$PIECE(^AUTTLOC(DUZ(2),0),U,2)_"."
SET AGQIO=IO
FOR G="AGQIO","DUZ"
SET ZTSAVE(G)=""
+3 DO ^%ZTLOAD
IF '$DATA(ZTSK)
GOTO DEV
KILL AG,AGIO,AGQIO,G,ZTDESC,ZTIO,ZTRTN,ZTSK,ZTUCI
DO ^%ZISC
+4 QUIT
START ;EP - From TaskMan.
+1 KILL ^TMP($JOB)
+2 ;S N="" F I=0:0 S N=$O(^DPT("B",N)) Q:N="" F DFN=0:0 S DFN=$O(^DPT("B",N,DFN)) Q:'DFN I $D(^DPT(DFN,0)),$P(^DPT(DFN,0),U)=N,$D(^DPT(DFN,"VET")) S ^TMP($J,$P(^DPT(DFN,0),U),DFN)=""
+3 ;IM22907 AG*7.1*2
SET N=""
FOR I=0:0
SET N=$ORDER(^DPT("B",N))
IF N=""
QUIT
FOR DFN=0:0
SET DFN=$ORDER(^DPT("B",N,DFN))
IF 'DFN
QUIT
IF $DATA(^DPT(DFN,0))
IF $PIECE(^DPT(DFN,0),U)=N
IF $DATA(^DPT(DFN,"VET"))
IF $PIECE($GET(^DPT(DFN,"VET")),U)'="Y"
QUIT
SET ^TMP($JOB,$PIECE(^DPT(DFN,0),U),DFN)=""
+4 IF $DATA(AGQIO)
FOR AGZ("I")=1:1
SET IOP=AGQIO
DO ^%ZIS
IF 'POP
QUIT
HANG 30
+5 SET AGEL("DFN")=""
SET (AGPGPG,N,T)=0
SET X=$PIECE(^DIC(4,DUZ(2),0),U)
DO CTR^AG
SET AG("LOC")=X
SET AG("USR")=$PIECE(^VA(200,DUZ,0),U)
SET AGBM=IOSL-10
IF $DATA(AGIO)
IF AGIO=IO
SET AGBM=IOSL-4
+6 XECUTE ^%ZOSF("UCI")
SET X="UCI: "_$PIECE(Y,",")
DO CTR^AG
SET AGUCI=X
+7 USE IO
DO NOW^AG
SET X="as of "_AGTIME
DO CTR^AG
SET AGTIME=X
DO HDR
L1 SET AGEL("DFN")=$ORDER(^TMP($JOB,AGEL("DFN")))
IF AGEL("DFN")=""
GOTO END
SET DFN=$ORDER(^TMP($JOB,AGEL("DFN"),""))
+1 KILL ^UTILITY("DIQ1",$JOB)
+2 ;AG*7.1*2 FOUND DURING TESTING - NOT PRINTING SSN/DOB BECAUSE DIQ QWAS SET FROM USER ENTERING 'EPT' OPTION
KILL DIC,DA,DR,DIQ
+3 WRITE !,$PIECE(^DPT(DFN,0),U)
SET DIC=2
SET DA=DFN
SET DR=.313
DO EN^DIQ1
IF $DATA(^(DR))
WRITE " (",^(DR),")"
+4 SET AG=""
IF $DATA(^AUPNPAT(DFN,41,DUZ(2),0))
IF $PIECE(^AUPNPAT(DFN,41,DUZ(2),0),U,3)]""
SET AG="*"
+5 DO DEAD^AGMAN
SET AG=AG_$SELECT($DATA(AG("DEAD")):"D",1:"")
IF AG]""
WRITE " (",AG,")"
+6 ;S DIC=2,DR=.09,DA=DFN D EN^DIQ1 W:$D(^(DR)) ?52,^(DR) S DR=.03 D EN^DIQ1 W:$D(^(DR)) ?66,$J(^(DR),10)
+7 ;IHS/SD/TPF AG*7.1*4
WRITE ?52,$$GET1^DIQ(9000001,DFN_",",1107.3)
SET DIC=2
SET DA=DFN
SET DR=.03
DO EN^DIQ1
IF $DATA(^(DR))
WRITE ?66,$JUSTIFY(^(DR),10)
+8 FOR AG=1:1
SET DIC=9000001.41
SET DA=DFN
SET AG("DRENT")=AG
SET DR=.02
DO ^AGDICLK
IF $DATA(AG("LKERR"))!($GET(AG("QUIT")))
QUIT
Begin DoDot:1
+9 WRITE !?20,$JUSTIFY(AG("LKPRINT"),6)
+10 SET AG("DRENT")=AG
SET DR=.01
DO ^AGDICLK
IF '$DATA(AG("LKERR"))
WRITE ?30,$PIECE(^DIC(4,AG("LKPRINT"),0),U)
+11 IF $Y>AGBM
DO RTRN^AG
IF $DATA(DUOUT)!($DATA(DTOUT))!($DATA(DFOUT))
SET AG("QUIT")=1
QUIT
+12 IF $Y>AGBM
DO HDR
End DoDot:1
+13 IF $GET(AG("QUIT"))
GOTO END1
+14 SET T=T+1
IF $Y>AGBM
DO RTRN^AG
IF $DATA(DUOUT)!$DATA(DTOUT)!$DATA(DFOUT)
GOTO END1
DO HDR
+15 GOTO L1
END WRITE !!,"Total Patients: ",T
KILL AG("HAT")
DO RTRN^AG
WRITE $$S^AGVDF("IOF")
END1 DO ^%ZISC
KILL AG,AGIO,AGQIO,AGTIME,AGBM,DA,AG("DENT"),DIC,DR,G,AGL,AG("LKDATA"),AG("LKERR"),AG("LKPRINT"),AG("LOC"),N,AGPCC,AGPGPG,T,AGUCI,AG("USR"),X,Y,^TMP($JOB)
IF $DATA(ZTQUEUED)
DO KILL^%ZTLOAD
+1 QUIT
HDR SET AGPGPG=AGPGPG+1
SET AG("LINE")="="
+1 WRITE $$S^AGVDF("IOF"),!!,AG("USR"),?72,"page ",AGPGPG,!,AG("LOC"),!?23,"ALL VETERANS - ALPHABETICAL LISTING",!,AGUCI,!?24,"('*' = INACTIVE), ('D' = DECEASED)",!,AGTIME,!!!?3,"Name (claim #)",?21,"IHS #",?30,"FACILITY",?56,"SSN",?70,"DOB"
DO LINE^AG
+2 QUIT
