- 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
