- 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 Feb 18, 2025@23:13:03 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