FHADRPT ; HISC/NCA - Print Dietetic Annual Report ;1/23/98 16:05
;;5.5;DIETETICS;;Jan 28, 2005
EN1 ; Get the Station Data for Printing
D GET^FHADR1 G:Y<1 KIL
S FHX1=+Y,LS=$E(DT,1,3) W !
Q0 K %DT S PRE="",FG=0,%DT="AEP",%DT("A")="Enter YR: "
D ^%DT S:$D(DTOUT) X="^" G KIL:U[X,Q0:Y<1
I $E(Y,1,3)>LS W *7," Do Not Enter Future Year." G Q0
I $E(Y,4,7)>0 W *7," Enter Year Only." G Q0
S Y=$E(Y,1,3)_"0000",PRE=Y,FG=1
S QTR=$E(PRE,5),YR=$E(PRE,2,3)
L0 K IOP,%ZIS,ZTUCI,ZTRTN,ZTSAVE,ZTDESC
W !!,"The report requires a 132 column printer.",!
S %ZIS="QM",%ZIS("B")="",IOP="Q" W !! D ^%ZIS K %ZIS,IOP G:POP KIL
I $D(IO("Q")) D G KIL
.S ZTRTN="TSK^FHADRPT",ZTREQ="@",ZTSAVE("ZTREQ")=""
.S ZTSAVE("FG")="",ZTSAVE("FHX1")="",ZTSAVE("PRE")=""
.S ZTSAVE("QTR")="",ZTSAVE("YR")=""
.S ZTDESC="Print the Dietetic Annual Report"
.D ^%ZTLOAD
.Q
E D G L0
.D ^%ZISC
.W !?5,"This is a very long and time consuming"
.W !?5,"report, it must be queued to print.",*7
.Q
G KIL
TSK ; Tasking the Report
U IO D Q1 D ^%ZISC K %ZIS,IOP,ZTSK G KIL
Q1 ; Display the Report
S PG=0,LIN=IOSL-6
S FHYR=$E(PRE,1,3) D NOW^%DTC S DTP=% D DTP^FH S HEAD=DTP
D EN2^FHADR1A,EN2^FHADR3A,EN2^FHADR2,Q1^FHADR4,Q0^FHADR5,EN2^FHADR6
D EN2^FHADR61,EN2^FHADR7,EN2^FHADR81,EN2^FHADR9A,EN2^FHADR10
Q
Q2 ; Find the Starting Month and Ending Month of Each Quarter
S (EDT,MTH,SDT)=""
S MTH=$P("October^January January^April April^July July^October"," ",QTR)
I MTH="" W *7," Error! Wrong Qtr" Q
L1 K %DT S X=$P(MTH,"^",1)_" "_(1700+$E(FHYR,1,3)) D ^%DT I QTR=1 S X1=+Y,X2=-365 D C^%DTC S X=$E(X,1,6)_"1" S SDT=+X G L2
S SDT=Y+1
L2 I SDT>DT S SDT="" Q
S X=$P(MTH,"^",2)_" "_(1700+$E(FHYR,1,3)) D ^%DT S X1=Y,X2=-1 D C^%DTC S EDT=X
I EDT>DT S EDT="" Q
S SDT=SDT\1,EDT=EDT\1
Q
HDR ; Report Header
W:'($E(IOST,1,2)'="C-"&'PG) @IOF S PG=PG+1
W !?13,HEAD,?50,"D I E T E T I C R E P O R T",?116,"Page ",PG
W !!?105 S Q1=$S(FG:"1 - 4",1:"") W Q1," Qtr FY ",$E(FHYR,2,3) Q
KIL G KILL^XUSCLEAN
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFHADRPT 2028 printed Dec 13, 2024@01:46:40 Page 2
FHADRPT ; HISC/NCA - Print Dietetic Annual Report ;1/23/98 16:05
+1 ;;5.5;DIETETICS;;Jan 28, 2005
EN1 ; Get the Station Data for Printing
+1 DO GET^FHADR1
if Y<1
GOTO KIL
+2 SET FHX1=+Y
SET LS=$EXTRACT(DT,1,3)
WRITE !
Q0 KILL %DT
SET PRE=""
SET FG=0
SET %DT="AEP"
SET %DT("A")="Enter YR: "
+1 DO ^%DT
if $DATA(DTOUT)
SET X="^"
if U[X
GOTO KIL
if Y<1
GOTO Q0
+2 IF $EXTRACT(Y,1,3)>LS
WRITE *7," Do Not Enter Future Year."
GOTO Q0
+3 IF $EXTRACT(Y,4,7)>0
WRITE *7," Enter Year Only."
GOTO Q0
+4 SET Y=$EXTRACT(Y,1,3)_"0000"
SET PRE=Y
SET FG=1
+5 SET QTR=$EXTRACT(PRE,5)
SET YR=$EXTRACT(PRE,2,3)
L0 KILL IOP,%ZIS,ZTUCI,ZTRTN,ZTSAVE,ZTDESC
+1 WRITE !!,"The report requires a 132 column printer.",!
+2 SET %ZIS="QM"
SET %ZIS("B")=""
SET IOP="Q"
WRITE !!
DO ^%ZIS
KILL %ZIS,IOP
if POP
GOTO KIL
+3 IF $DATA(IO("Q"))
Begin DoDot:1
+4 SET ZTRTN="TSK^FHADRPT"
SET ZTREQ="@"
SET ZTSAVE("ZTREQ")=""
+5 SET ZTSAVE("FG")=""
SET ZTSAVE("FHX1")=""
SET ZTSAVE("PRE")=""
+6 SET ZTSAVE("QTR")=""
SET ZTSAVE("YR")=""
+7 SET ZTDESC="Print the Dietetic Annual Report"
+8 DO ^%ZTLOAD
+9 QUIT
End DoDot:1
GOTO KIL
+10 IF '$TEST
Begin DoDot:1
+11 DO ^%ZISC
+12 WRITE !?5,"This is a very long and time consuming"
+13 WRITE !?5,"report, it must be queued to print.",*7
+14 QUIT
End DoDot:1
GOTO L0
+15 GOTO KIL
TSK ; Tasking the Report
+1 USE IO
DO Q1
DO ^%ZISC
KILL %ZIS,IOP,ZTSK
GOTO KIL
Q1 ; Display the Report
+1 SET PG=0
SET LIN=IOSL-6
+2 SET FHYR=$EXTRACT(PRE,1,3)
DO NOW^%DTC
SET DTP=%
DO DTP^FH
SET HEAD=DTP
+3 DO EN2^FHADR1A
DO EN2^FHADR3A
DO EN2^FHADR2
DO Q1^FHADR4
DO Q0^FHADR5
DO EN2^FHADR6
+4 DO EN2^FHADR61
DO EN2^FHADR7
DO EN2^FHADR81
DO EN2^FHADR9A
DO EN2^FHADR10
+5 QUIT
Q2 ; Find the Starting Month and Ending Month of Each Quarter
+1 SET (EDT,MTH,SDT)=""
+2 SET MTH=$PIECE("October^January January^April April^July July^October"," ",QTR)
+3 IF MTH=""
WRITE *7," Error! Wrong Qtr"
QUIT
L1 KILL %DT
SET X=$PIECE(MTH,"^",1)_" "_(1700+$EXTRACT(FHYR,1,3))
DO ^%DT
IF QTR=1
SET X1=+Y
SET X2=-365
DO C^%DTC
SET X=$EXTRACT(X,1,6)_"1"
SET SDT=+X
GOTO L2
+1 SET SDT=Y+1
L2 IF SDT>DT
SET SDT=""
QUIT
+1 SET X=$PIECE(MTH,"^",2)_" "_(1700+$EXTRACT(FHYR,1,3))
DO ^%DT
SET X1=Y
SET X2=-1
DO C^%DTC
SET EDT=X
+2 IF EDT>DT
SET EDT=""
QUIT
+3 SET SDT=SDT\1
SET EDT=EDT\1
+4 QUIT
HDR ; Report Header
+1 if '($EXTRACT(IOST,1,2)'="C-"&'PG)
WRITE @IOF
SET PG=PG+1
+2 WRITE !?13,HEAD,?50,"D I E T E T I C R E P O R T",?116,"Page ",PG
+3 WRITE !!?105
SET Q1=$SELECT(FG:"1 - 4",1:"")
WRITE Q1," Qtr FY ",$EXTRACT(FHYR,2,3)
QUIT
KIL GOTO KILL^XUSCLEAN
