AGEMARP ; VNGT/IHS/DLS - Patient Email Listing ; May 14, 2010
;;7.1;PATIENT REGISTRATION;**8,9**;AUG 25, 2005
;
VAR N TYPE,DL,SDL,AGIO
K ^TMP("AGEMARP",$J)
;
; Initialize Variables
;
S DL="^"
S SDL=","
;
D GETPARMS
I $G(TYPE("DATE"))="" G EXIT
I $G(TYPE("DATE","FROM"))="" G EXIT
I $G(TYPE("DATE","TO"))="" G EXIT
I $G(TYPE("FORMAT"))="" G EXIT
DEV ;
S %ZIS="QA"
D ^%ZIS
I POP N IOP S IOP=ION D ^%ZIS Q
I $G(IO("Q")) D QUE D HOME^%ZIS Q
U IO
D GO
D ^%ZISC
D HOME^%ZIS
Q
GO ; Start Processing
D GETDATA
D PRINT
G EXIT
;
Q
;
GETPARMS ; Get Report Parameters
N X,Y,DIR
S DIR("A")=" Select PARAMETER"
S DIR("B")="L"
S DIR(0)="SO^L:LAST UPDATE;A:APPOINTMENT DATE"
S DIR("L",1)=" Choose from:"
S DIR("L",2)=" L LAST UPDATE"
S DIR("L",3)=" A APPOINTMENT DATE"
S DIR("L",4)=""
D ^DIR
I X["^" Q
; Get Output type
S TYPE("DATE")=X D GETDTS
I $G(TYPE("DATE","FROM"))="" Q
I $G(TYPE("DATE","TO"))="" Q
N DIR
S DIR("A")=" Select Output Format"
S DIR("B")="S"
S DIR(0)="SO^S:STANDARD;F:FLAT FILE"
S DIR("L",1)=" S STANDARD"
S DIR("L",2)=" F FLAT (Datafile)"
S DIR("L",3)=""
D ^DIR
I Y["^" Q
S TYPE("FORMAT")=X
W !
Q
;
GETDTS ; Get Date Range
D START I $G(TYPE("DATE","FROM"))="" Q
D END I $G(TYPE("DATE","TO"))="" Q
Q
START ; Get Start Date
N X,Y,DIR
S DIR("A")=" Select START DATE"
S DIR("B")="T"
S DIR(0)="DO"
W !
D ^DIR
I Y["^" Q
I TYPE("DATE")="L",Y>DT D G START
. W !!,?11,"Date cannot be in the future.",!
S TYPE("DATE","FROM")=Y D DD^%DT S $P(TYPE("DATE","FROM"),U,2)=Y W " ",Y
Q
;
END ; Get end date
N X,Y,DIR
S DIR("A")=" Select END DATE"
S DIR("B")="T"
S DIR(0)="DO"
W !
D ^DIR
I Y["^" Q
I TYPE("DATE","FROM")>Y D G END
. W !!,?11,"End date cannot be before start date.",!
I TYPE("DATE")="L",Y>DT D G END
. W !!,?11,"Date cannot be in the future.",!
S TYPE("DATE","TO")=Y D DD^%DT S $P(TYPE("DATE","TO"),U,2)=Y W " ",Y
Q
;
GETDATA ; Gather Report data
N TOTCNT,AIANCNT,PATNT,Y,EXTDT
S (TOTCNT,AIANCNT)=0
S Y=DT D DD^%DT S EXTDT=Y
S ^TMP("AGEMARP",$J,0)=$$GET1^DIQ(4,DUZ(2),.01)_DL_EXTDT_DL_$S($G(TYPE("DATE"))="L":"Last Update",1:"Appointment Date")_DL_$P($G(TYPE("DATE","FROM")),U,2)_DL_$P($G(TYPE("DATE","TO")),U,2)
S PATNT=""
F S PATNT=$O(^AUPNPAT("B",PATNT)) Q:+PATNT=0 D
. N PTNTNM,PTNTEM,CHRTNO,ACCESS,PERMIT,OK,ACCIEN1,ACCIEN2,ACCESS,ACCCNT
. S PTNTEM=$$GET1^DIQ(9000001,PATNT,1802)
. Q:PTNTEM=""
. S OK=0
. D DTCHK(PATNT,.OK)
. I OK D
. . S CHRTNO=$P($G(^AUPNPAT(PATNT,41,DUZ(2),0)),U,2)
. . S PTNTNM=$$GET1^DIQ(2,PATNT,.01)
. . S ACCIEN1=0,ACCESS=""
. . S ACCCNT=$P($G(^AUPNPAT(PATNT,81,0)),U,3)
. . I ACCCNT]"" F S ACCIEN1=$O(^AUPNPAT(PATNT,81,ACCCNT,1,ACCIEN1)) Q:+ACCIEN1=0 D
. . . S ACCIEN2=ACCIEN1_","_ACCCNT_","_PATNT
. . . S ACCESS=ACCESS_$$GET1^DIQ(9000001.811,ACCIEN2,.01)_SDL
. . I $E(ACCESS,$L(ACCESS))=SDL S ACCESS=$E(ACCESS,1,($L(ACCESS)-1))
. . S PERMIT=$$GET1^DIQ(9000001,PATNT,4001)
. . I $$GET1^DIQ(9000001,PATNT,1111,"I")=1 S AIANCNT=AIANCNT+1
. . S TOTCNT=TOTCNT+1
. . S ^TMP("AGEMARP",$J,PTNTNM,PATNT)=CHRTNO_DL_PTNTEM_DL_ACCESS_DL_PERMIT
S ^TMP("AGEMARP",$J,0)=^TMP("AGEMARP",$J,0)_DL_TOTCNT_"-Total"_DL_AIANCNT_"-Total AI/AN"
Q
;
DTCHK(PATNT,OK) ; Check Date Parameters
S OK=0
N VIEN,STDT,ENDT,VDT
S STDT=+TYPE("DATE","FROM")-1
S ENDT=+TYPE("DATE","TO")+1
I TYPE("DATE")="A" D
. S VIEN=0
. F S VIEN=$O(^AUPNVSIT("AC",PATNT,VIEN)) Q:(VIEN="")!(OK) D
. . S VDT=$P($G(^AUPNVSIT(VIEN,0)),U)\1
. . I VDT>STDT,VDT<ENDT S OK=1
. . Q:OK
I TYPE("DATE")="L" D
. N UDT
. S UDT=$$GET1^DIQ(9000001,PATNT,.03,"I")
. I UDT>STDT,UDT<ENDT S OK=1
. Q
Q
;
PRINT ; Top level print engine
I $O(^TMP("AGEMARP",$J,0))="" W !!," No Records Found!" H 3 Q
I TYPE("FORMAT")="S" D PRINTS
I TYPE("FORMAT")="F" D PRINTF
Q
PRINTS ; Generate Standard Output
N REC,LINECNT,ESCAPE,RECOUT,HRNOUT,EMAOUT,WHROUT,PRMOUT,PAGE,TYP,POP,ESCAPE,AGTOT,AGT,PATNT
S PAGE=0,ESCAPE=0
S TYP=$S(TYPE("DATE")="A":" APPTS ",1:" UPDATES ")
I $G(AGIO)="" U IO
N AGLINE
S $P(AGLINE("EQ"),"=",80)=""
S $P(AGLINE("DASH"),"-",80)=""
D HDR
S REC=0
F S REC=$O(^TMP("AGEMARP",$J,REC)) Q:(REC="")!(ESCAPE) D
. S PATNT=0
. F S PATNT=$O(^TMP("AGEMARP",$J,REC,PATNT)) Q:(PATNT="")!(ESCAPE) D
. . N WHERCNT
. . S RECOUT=^TMP("AGEMARP",$J,REC,PATNT)
. . S HRNOUT=$P(RECOUT,DL)
. . S EMAOUT=$P(RECOUT,DL,2)
. . S WHROUT=$P(RECOUT,DL,3)
. . S PRMOUT=$P(RECOUT,DL,4)
. . W !,HRNOUT,?9,$E(REC,1,20),?30,EMAOUT
. . I $L(EMAOUT)>24 W !
. . W ?55,$E($P(WHROUT,","),1,19),?74," ",PRMOUT
. . I WHROUT'="" D
. . . S AGT=$E($P(WHROUT,","),1,19)
. . . S AGTOT(AGT)=$G(AGTOT(AGT))+1
. . . S AGTOT("TOTAL")=$G(AGTOT("TOTAL"))+1
. . I $L(WHROUT,SDL)>1 D
. . . S WHERCNT=$L(WHROUT,SDL)
. . . N I F I=2:1:WHERCNT D
. . . . W !,?55,$P(WHROUT,SDL,I)
. . . . S AGT=$P(WHROUT,SDL,I)
. . . . S AGTOT(AGT)=$G(AGTOT(AGT))+1
. . . . S AGTOT("TOTAL")=$G(AGTOT("TOTAL"))+1
. . I $O(^TMP("AGEMARP",$J,REC,PATNT))'="" W !,AGLINE("DASH")
. . I $E(IOST)="C",$Y>(IOSL-5) K DIR D RTRN^AG S ESCAPE=X=U D:'ESCAPE HDR
. . I $E(IOST)'="C",$Y>(IOSL-17) W !! D HDR
I 'ESCAPE D
. W !,AGLINE("EQ")
. S AGT=""
. W !!,"TOTALS",!,"----------------"
. F S AGT=$O(AGTOT(AGT)) Q:AGT="" D
. . I AGT'="TOTAL" D
. . . W !,AGT
. . . I AGT="TRIBE/COMMUNITY CEN" W "TER"
. . . W ?22
. . . W $J($G(AGTOT(AGT)),10)
. W !,"================================="
. W !,$J($G(AGTOT("TOTAL")),32),!!
I $E(IOST)="C",REC="" K DIR D RTRN^AG
I $E(IOST)'="C" D CLOSE^%ZISH(IO)
Q
;XU
HDR ; Print Header
S PAGE=PAGE+1
W @IOF
W !,$$GET1^DIQ(200,DUZ,.01)
W ?(80-$L($$GET1^DIQ(4,DUZ(2),.01)))/2,$$GET1^DIQ(4,DUZ(2),.01)
W ?70,"Page ",PAGE
W !,?33,"EMAIL LISTING"
I TYPE("DATE")="L" W !,?19,"LAST UPDATE: "
I TYPE("DATE")="A" W !,?16,"APPOINTMENT DATE: "
I +TYPE("DATE","FROM")=2010101,+TYPE("DATE","TO")=3991231 W "FOR ALL APPOINTMENTS"
I +TYPE("DATE","FROM")=2010101,+TYPE("DATE","TO")'=3991231 W "FOR ALL",TYP,"THROUGH ",$P(TYPE("DATE","TO"),U,2)
I +TYPE("DATE","FROM")'=2010101,+TYPE("DATE","TO")=3991231 W "FOR ALL",TYP,"FROM ",$P(TYPE("DATE","FROM"),U,2)
I +TYPE("DATE","FROM")'=2010101,+TYPE("DATE","TO")'=3991231 D
. W $P(TYPE("DATE","FROM"),U,2)
. W " - "
. W $P(TYPE("DATE","TO"),U,2)
W !!,"HRN",?9,"NAME",?30,"EMAIL ADDRESS",?55,"WHERE",?69,"PERMISSION"
W !,AGLINE("EQ")
Q
;
PRINTF ; Generate "Flat" Datafile Output
N REC,RECOUT,POP,OUTFNM,PATH,FILENAME,PNLNGTH,LPCNT,ESCAPE,I,PATNT
I $G(AQGIO)="" U IO
I $E(IOST)="C" W @IOF
S REC=0,ESCAPE=0
W ^TMP("AGEMARP",$J,REC)
F S REC=$O(^TMP("AGEMARP",$J,REC)) Q:REC=""!ESCAPE D
. S PATNT=0
. F S PATNT=$O(^TMP("AGEMARP",$J,REC,PATNT)) Q:PATNT="" D
. . S RECOUT=REC_DL_^TMP("AGEMARP",$J,REC,PATNT)
. . W !,RECOUT
. . I $E(IOST)="C",$Y>(IOSL-5) K DIR D RTRN^AG S ESCAPE=X=U W @IOF
I $E(IOST)="C",REC="" K DIR D RTRN^AG
I $E(IOST)'="C" W ! D CLOSE^%ZISH(IO)
S IOSL=24
Q
;
QUE ;QUE TO TASKMAN
K IO("Q")
S ZTRTN="GO^AGEMARP",ZTDESC="Patient Email Address Listing "
S ZTSAVE("*")=""
K ZTSK D ^%ZTLOAD
I $D(ZTSK)[0 W !!?5,"Report Cancelled!"
E W !!?5,"Task # ",ZTSK," queued.",!
H 3
Q
;
EXIT ; Exit the program
K ^TMP("AGEMARP",$J)
Q
;
AGEMARP ; VNGT/IHS/DLS - Patient Email Listing ; May 14, 2010
+1 ;;7.1;PATIENT REGISTRATION;**8,9**;AUG 25, 2005
+2 ;
VAR NEW TYPE,DL,SDL,AGIO
+1 KILL ^TMP("AGEMARP",$JOB)
+2 ;
+3 ; Initialize Variables
+4 ;
+5 SET DL="^"
+6 SET SDL=","
+7 ;
+8 DO GETPARMS
+9 IF $GET(TYPE("DATE"))=""
GOTO EXIT
+10 IF $GET(TYPE("DATE","FROM"))=""
GOTO EXIT
+11 IF $GET(TYPE("DATE","TO"))=""
GOTO EXIT
+12 IF $GET(TYPE("FORMAT"))=""
GOTO EXIT
DEV ;
+1 SET %ZIS="QA"
+2 DO ^%ZIS
+3 IF POP
NEW IOP
SET IOP=ION
DO ^%ZIS
QUIT
+4 IF $GET(IO("Q"))
DO QUE
DO HOME^%ZIS
QUIT
+5 USE IO
+6 DO GO
+7 DO ^%ZISC
+8 DO HOME^%ZIS
+9 QUIT
GO ; Start Processing
+1 DO GETDATA
+2 DO PRINT
+3 GOTO EXIT
+4 ;
+5 QUIT
+6 ;
GETPARMS ; Get Report Parameters
+1 NEW X,Y,DIR
+2 SET DIR("A")=" Select PARAMETER"
+3 SET DIR("B")="L"
+4 SET DIR(0)="SO^L:LAST UPDATE;A:APPOINTMENT DATE"
+5 SET DIR("L",1)=" Choose from:"
+6 SET DIR("L",2)=" L LAST UPDATE"
+7 SET DIR("L",3)=" A APPOINTMENT DATE"
+8 SET DIR("L",4)=""
+9 DO ^DIR
+10 IF X["^"
QUIT
+11 ; Get Output type
+12 SET TYPE("DATE")=X
DO GETDTS
+13 IF $GET(TYPE("DATE","FROM"))=""
QUIT
+14 IF $GET(TYPE("DATE","TO"))=""
QUIT
+15 NEW DIR
+16 SET DIR("A")=" Select Output Format"
+17 SET DIR("B")="S"
+18 SET DIR(0)="SO^S:STANDARD;F:FLAT FILE"
+19 SET DIR("L",1)=" S STANDARD"
+20 SET DIR("L",2)=" F FLAT (Datafile)"
+21 SET DIR("L",3)=""
+22 DO ^DIR
+23 IF Y["^"
QUIT
+24 SET TYPE("FORMAT")=X
+25 WRITE !
+26 QUIT
+27 ;
GETDTS ; Get Date Range
+1 DO START
IF $GET(TYPE("DATE","FROM"))=""
QUIT
+2 DO END
IF $GET(TYPE("DATE","TO"))=""
QUIT
+3 QUIT
START ; Get Start Date
+1 NEW X,Y,DIR
+2 SET DIR("A")=" Select START DATE"
+3 SET DIR("B")="T"
+4 SET DIR(0)="DO"
+5 WRITE !
+6 DO ^DIR
+7 IF Y["^"
QUIT
+8 IF TYPE("DATE")="L"
IF Y>DT
Begin DoDot:1
+9 WRITE !!,?11,"Date cannot be in the future.",!
End DoDot:1
GOTO START
+10 SET TYPE("DATE","FROM")=Y
DO DD^%DT
SET $PIECE(TYPE("DATE","FROM"),U,2)=Y
WRITE " ",Y
+11 QUIT
+12 ;
END ; Get end date
+1 NEW X,Y,DIR
+2 SET DIR("A")=" Select END DATE"
+3 SET DIR("B")="T"
+4 SET DIR(0)="DO"
+5 WRITE !
+6 DO ^DIR
+7 IF Y["^"
QUIT
+8 IF TYPE("DATE","FROM")>Y
Begin DoDot:1
+9 WRITE !!,?11,"End date cannot be before start date.",!
End DoDot:1
GOTO END
+10 IF TYPE("DATE")="L"
IF Y>DT
Begin DoDot:1
+11 WRITE !!,?11,"Date cannot be in the future.",!
End DoDot:1
GOTO END
+12 SET TYPE("DATE","TO")=Y
DO DD^%DT
SET $PIECE(TYPE("DATE","TO"),U,2)=Y
WRITE " ",Y
+13 QUIT
+14 ;
GETDATA ; Gather Report data
+1 NEW TOTCNT,AIANCNT,PATNT,Y,EXTDT
+2 SET (TOTCNT,AIANCNT)=0
+3 SET Y=DT
DO DD^%DT
SET EXTDT=Y
+4 SET ^TMP("AGEMARP",$JOB,0)=$$GET1^DIQ(4,DUZ(2),.01)_DL_EXTDT_DL_$SELECT($GET(TYPE("DATE"))="L":"Last Update",1:"Appointment Date")_DL_$PIECE($GET(TYPE("DATE","FROM")),U,2)_DL_$PIECE($GET(TYPE("DATE","TO")),U,2)
+5 SET PATNT=""
+6 FOR
SET PATNT=$ORDER(^AUPNPAT("B",PATNT))
IF +PATNT=0
QUIT
Begin DoDot:1
+7 NEW PTNTNM,PTNTEM,CHRTNO,ACCESS,PERMIT,OK,ACCIEN1,ACCIEN2,ACCESS,ACCCNT
+8 SET PTNTEM=$$GET1^DIQ(9000001,PATNT,1802)
+9 IF PTNTEM=""
QUIT
+10 SET OK=0
+11 DO DTCHK(PATNT,.OK)
+12 IF OK
Begin DoDot:2
+13 SET CHRTNO=$PIECE($GET(^AUPNPAT(PATNT,41,DUZ(2),0)),U,2)
+14 SET PTNTNM=$$GET1^DIQ(2,PATNT,.01)
+15 SET ACCIEN1=0
SET ACCESS=""
+16 SET ACCCNT=$PIECE($GET(^AUPNPAT(PATNT,81,0)),U,3)
+17 IF ACCCNT]""
FOR
SET ACCIEN1=$ORDER(^AUPNPAT(PATNT,81,ACCCNT,1,ACCIEN1))
IF +ACCIEN1=0
QUIT
Begin DoDot:3
+18 SET ACCIEN2=ACCIEN1_","_ACCCNT_","_PATNT
+19 SET ACCESS=ACCESS_$$GET1^DIQ(9000001.811,ACCIEN2,.01)_SDL
End DoDot:3
+20 IF $EXTRACT(ACCESS,$LENGTH(ACCESS))=SDL
SET ACCESS=$EXTRACT(ACCESS,1,($LENGTH(ACCESS)-1))
+21 SET PERMIT=$$GET1^DIQ(9000001,PATNT,4001)
+22 IF $$GET1^DIQ(9000001,PATNT,1111,"I")=1
SET AIANCNT=AIANCNT+1
+23 SET TOTCNT=TOTCNT+1
+24 SET ^TMP("AGEMARP",$JOB,PTNTNM,PATNT)=CHRTNO_DL_PTNTEM_DL_ACCESS_DL_PERMIT
End DoDot:2
End DoDot:1
+25 SET ^TMP("AGEMARP",$JOB,0)=^TMP("AGEMARP",$JOB,0)_DL_TOTCNT_"-Total"_DL_AIANCNT_"-Total AI/AN"
+26 QUIT
+27 ;
DTCHK(PATNT,OK) ; Check Date Parameters
+1 SET OK=0
+2 NEW VIEN,STDT,ENDT,VDT
+3 SET STDT=+TYPE("DATE","FROM")-1
+4 SET ENDT=+TYPE("DATE","TO")+1
+5 IF TYPE("DATE")="A"
Begin DoDot:1
+6 SET VIEN=0
+7 FOR
SET VIEN=$ORDER(^AUPNVSIT("AC",PATNT,VIEN))
IF (VIEN="")!(OK)
QUIT
Begin DoDot:2
+8 SET VDT=$PIECE($GET(^AUPNVSIT(VIEN,0)),U)\1
+9 IF VDT>STDT
IF VDT<ENDT
SET OK=1
+10 IF OK
QUIT
End DoDot:2
End DoDot:1
+11 IF TYPE("DATE")="L"
Begin DoDot:1
+12 NEW UDT
+13 SET UDT=$$GET1^DIQ(9000001,PATNT,.03,"I")
+14 IF UDT>STDT
IF UDT<ENDT
SET OK=1
+15 QUIT
End DoDot:1
+16 QUIT
+17 ;
PRINT ; Top level print engine
+1 IF $ORDER(^TMP("AGEMARP",$JOB,0))=""
WRITE !!," No Records Found!"
HANG 3
QUIT
+2 IF TYPE("FORMAT")="S"
DO PRINTS
+3 IF TYPE("FORMAT")="F"
DO PRINTF
+4 QUIT
PRINTS ; Generate Standard Output
+1 NEW REC,LINECNT,ESCAPE,RECOUT,HRNOUT,EMAOUT,WHROUT,PRMOUT,PAGE,TYP,POP,ESCAPE,AGTOT,AGT,PATNT
+2 SET PAGE=0
SET ESCAPE=0
+3 SET TYP=$SELECT(TYPE("DATE")="A":" APPTS ",1:" UPDATES ")
+4 IF $GET(AGIO)=""
USE IO
+5 NEW AGLINE
+6 SET $PIECE(AGLINE("EQ"),"=",80)=""
+7 SET $PIECE(AGLINE("DASH"),"-",80)=""
+8 DO HDR
+9 SET REC=0
+10 FOR
SET REC=$ORDER(^TMP("AGEMARP",$JOB,REC))
IF (REC="")!(ESCAPE)
QUIT
Begin DoDot:1
+11 SET PATNT=0
+12 FOR
SET PATNT=$ORDER(^TMP("AGEMARP",$JOB,REC,PATNT))
IF (PATNT="")!(ESCAPE)
QUIT
Begin DoDot:2
+13 NEW WHERCNT
+14 SET RECOUT=^TMP("AGEMARP",$JOB,REC,PATNT)
+15 SET HRNOUT=$PIECE(RECOUT,DL)
+16 SET EMAOUT=$PIECE(RECOUT,DL,2)
+17 SET WHROUT=$PIECE(RECOUT,DL,3)
+18 SET PRMOUT=$PIECE(RECOUT,DL,4)
+19 WRITE !,HRNOUT,?9,$EXTRACT(REC,1,20),?30,EMAOUT
+20 IF $LENGTH(EMAOUT)>24
WRITE !
+21 WRITE ?55,$EXTRACT($PIECE(WHROUT,","),1,19),?74," ",PRMOUT
+22 IF WHROUT'=""
Begin DoDot:3
+23 SET AGT=$EXTRACT($PIECE(WHROUT,","),1,19)
+24 SET AGTOT(AGT)=$GET(AGTOT(AGT))+1
+25 SET AGTOT("TOTAL")=$GET(AGTOT("TOTAL"))+1
End DoDot:3
+26 IF $LENGTH(WHROUT,SDL)>1
Begin DoDot:3
+27 SET WHERCNT=$LENGTH(WHROUT,SDL)
+28 NEW I
FOR I=2:1:WHERCNT
Begin DoDot:4
+29 WRITE !,?55,$PIECE(WHROUT,SDL,I)
+30 SET AGT=$PIECE(WHROUT,SDL,I)
+31 SET AGTOT(AGT)=$GET(AGTOT(AGT))+1
+32 SET AGTOT("TOTAL")=$GET(AGTOT("TOTAL"))+1
End DoDot:4
End DoDot:3
+33 IF $ORDER(^TMP("AGEMARP",$JOB,REC,PATNT))'=""
WRITE !,AGLINE("DASH")
+34 IF $EXTRACT(IOST)="C"
IF $Y>(IOSL-5)
KILL DIR
DO RTRN^AG
SET ESCAPE=X=U
IF 'ESCAPE
DO HDR
+35 IF $EXTRACT(IOST)'="C"
IF $Y>(IOSL-17)
WRITE !!
DO HDR
End DoDot:2
End DoDot:1
+36 IF 'ESCAPE
Begin DoDot:1
+37 WRITE !,AGLINE("EQ")
+38 SET AGT=""
+39 WRITE !!,"TOTALS",!,"----------------"
+40 FOR
SET AGT=$ORDER(AGTOT(AGT))
IF AGT=""
QUIT
Begin DoDot:2
+41 IF AGT'="TOTAL"
Begin DoDot:3
+42 WRITE !,AGT
+43 IF AGT="TRIBE/COMMUNITY CEN"
WRITE "TER"
+44 WRITE ?22
+45 WRITE $JUSTIFY($GET(AGTOT(AGT)),10)
End DoDot:3
End DoDot:2
+46 WRITE !,"================================="
+47 WRITE !,$JUSTIFY($GET(AGTOT("TOTAL")),32),!!
End DoDot:1
+48 IF $EXTRACT(IOST)="C"
IF REC=""
KILL DIR
DO RTRN^AG
+49 IF $EXTRACT(IOST)'="C"
DO CLOSE^%ZISH(IO)
+50 QUIT
+51 ;XU
HDR ; Print Header
+1 SET PAGE=PAGE+1
+2 WRITE @IOF
+3 WRITE !,$$GET1^DIQ(200,DUZ,.01)
+4 WRITE ?(80-$LENGTH($$GET1^DIQ(4,DUZ(2),.01)))/2,$$GET1^DIQ(4,DUZ(2),.01)
+5 WRITE ?70,"Page ",PAGE
+6 WRITE !,?33,"EMAIL LISTING"
+7 IF TYPE("DATE")="L"
WRITE !,?19,"LAST UPDATE: "
+8 IF TYPE("DATE")="A"
WRITE !,?16,"APPOINTMENT DATE: "
+9 IF +TYPE("DATE","FROM")=2010101
IF +TYPE("DATE","TO")=3991231
WRITE "FOR ALL APPOINTMENTS"
+10 IF +TYPE("DATE","FROM")=2010101
IF +TYPE("DATE","TO")'=3991231
WRITE "FOR ALL",TYP,"THROUGH ",$PIECE(TYPE("DATE","TO"),U,2)
+11 IF +TYPE("DATE","FROM")'=2010101
IF +TYPE("DATE","TO")=3991231
WRITE "FOR ALL",TYP,"FROM ",$PIECE(TYPE("DATE","FROM"),U,2)
+12 IF +TYPE("DATE","FROM")'=2010101
IF +TYPE("DATE","TO")'=3991231
Begin DoDot:1
+13 WRITE $PIECE(TYPE("DATE","FROM"),U,2)
+14 WRITE " - "
+15 WRITE $PIECE(TYPE("DATE","TO"),U,2)
End DoDot:1
+16 WRITE !!,"HRN",?9,"NAME",?30,"EMAIL ADDRESS",?55,"WHERE",?69,"PERMISSION"
+17 WRITE !,AGLINE("EQ")
+18 QUIT
+19 ;
PRINTF ; Generate "Flat" Datafile Output
+1 NEW REC,RECOUT,POP,OUTFNM,PATH,FILENAME,PNLNGTH,LPCNT,ESCAPE,I,PATNT
+2 IF $GET(AQGIO)=""
USE IO
+3 IF $EXTRACT(IOST)="C"
WRITE @IOF
+4 SET REC=0
SET ESCAPE=0
+5 WRITE ^TMP("AGEMARP",$JOB,REC)
+6 FOR
SET REC=$ORDER(^TMP("AGEMARP",$JOB,REC))
IF REC=""!ESCAPE
QUIT
Begin DoDot:1
+7 SET PATNT=0
+8 FOR
SET PATNT=$ORDER(^TMP("AGEMARP",$JOB,REC,PATNT))
IF PATNT=""
QUIT
Begin DoDot:2
+9 SET RECOUT=REC_DL_^TMP("AGEMARP",$JOB,REC,PATNT)
+10 WRITE !,RECOUT
+11 IF $EXTRACT(IOST)="C"
IF $Y>(IOSL-5)
KILL DIR
DO RTRN^AG
SET ESCAPE=X=U
WRITE @IOF
End DoDot:2
End DoDot:1
+12 IF $EXTRACT(IOST)="C"
IF REC=""
KILL DIR
DO RTRN^AG
+13 IF $EXTRACT(IOST)'="C"
WRITE !
DO CLOSE^%ZISH(IO)
+14 SET IOSL=24
+15 QUIT
+16 ;
QUE ;QUE TO TASKMAN
+1 KILL IO("Q")
+2 SET ZTRTN="GO^AGEMARP"
SET ZTDESC="Patient Email Address Listing "
+3 SET ZTSAVE("*")=""
+4 KILL ZTSK
DO ^%ZTLOAD
+5 IF $DATA(ZTSK)[0
WRITE !!?5,"Report Cancelled!"
+6 IF '$TEST
WRITE !!?5,"Task # ",ZTSK," queued.",!
+7 HANG 3
+8 QUIT
+9 ;
EXIT ; Exit the program
+1 KILL ^TMP("AGEMARP",$JOB)
+2 QUIT
+3 ;
