ACKQCDD ;AUG/JLTP BIR/PTD HCIOFO/AG -Generate A&SP Service CDR for a Division; [ 03/03/98 3:10 PM ]
;;3.0;QUASAR;;Feb 11, 2000
;Per VHA Directive 10-93-142, this routine SHOULD NOT be modified.
;
SITE ; check whether the CDR should be run for the site or for each Division
S ACKQCDR=$$GET1^DIQ(509850.8,"1,",.1,"I")
I ACKQCDR'="D" G EXIT ; parameter not set to Division
;
OPTN ;Introduce option.
W @IOF,!,"This option generates and prints the Audiology and"
W !,"Speech Pathology Service Cost Distribution Report"
W !,"for a single Division.",!
;
K ^TMP("ACKQCDD",$J)
;
; prompt for Division
S ACKDIV=$$DIV^ACKQUTL2(1,.ACKDIVX,"AI")
S ACKDIV=$O(ACKDIVX(""))
; if no division selected then exit
I +ACKDIV=0 G EXIT
; ask if data is to be saved
; returns ACKSAV
D SAVE G:$D(DIRUT) EXIT
; get the date range
; returns ACKSD and ACKED and ACKXRNG
D DATES G:$D(DIRUT) EXIT
;
HRS ; calculate the total clinic hours
D CLINH^ACKQCDD2
; if no hours found, ask user if they want to proceed.
I '(ACKTCH+ACKTSH),'$$OK G EXIT
;
; display total clinic hours and total student hours
W !!,"Total Clinic Hours for ",ACKXRNG,": ",$J((ACKTCH+ACKTSH),0,2)
I ACKTSH D
. W !,"Of that total, ",$J(ACKTSH,0,2)," hours are Instructional Support (.12)."
. W !,"Remaining Clinic Hours: ",$J(ACKTCH,0,2)
;
; prompt for total paid hours
D TPH^ACKQCDD2 G:$D(DIRUT) EXIT S ACKRTH=ACKTPH
;
INPUT ;
; ask user for flat values for Admin Support and Cont Education
S ACKCATI="E",ACKCAT="ADMIN SUPT (.13) & CONT ED (.14)"
D YNFLAT G:$D(DIRUT) EXIT
I ACKFLAT D FNH G:$D(DIRUT) EXIT
I 'ACKFLAT D G:$D(DIRUT) EXIT
.S ACKIC=0
.F S ACKIC=$O(^ACK(509850,"AT",ACKCATI,ACKIC)) Q:'ACKIC D Q:$D(DIRUT)
..S ACKCDZ=^ACK(509850,ACKIC,0)
..I +ACKCDZ'[.12 D INDCAT^ACKQCDD2(ACKIC) Q:$D(DIRUT)
;
; ask user for flat values for Research
S ACKCATI="R",ACKCAT="RESEARCH"
D YNFLAT G:$D(DIRUT) EXIT
I ACKFLAT D FNH G:$D(DIRUT) EXIT
I 'ACKFLAT D G:$D(DIRUT) EXIT
.S ACKIC=0
.F S ACKIC=$O(^ACK(509850,"AT",ACKCATI,ACKIC)) Q:'ACKIC D Q:$D(DIRUT)
..S ACKCDZ=^ACK(509850,ACKIC,0)
..I +ACKCDZ'[.12 D INDCAT^ACKQCDD2(ACKIC) Q:$D(DIRUT)
;
PASS ; now do Pass-through accounts
W !!,"Now for pass through CDR accounts..."
;
; prompt for each pass-through account until user exits
F D PASS^ACKQCDD2 I $D(DIRUT) K DIRUT Q
;
; calculate remaining hours
S ACKRTH=ACKRTH-(ACKTCH+ACKTSH)
;
; check there are no remaining hours if there are no clinic hours left
I 'ACKTCH,ACKRTH D G EXIT
. W !!,$C(7),"You have hours remaining but no clinic visits to which they can be"
. W !,"distributed! That won't work...",!!
;
; distribute remaining hours
I ACKRTH D DISREM^ACKQCDD2
; convert values to percentages, index the file
D PERCENT^ACKQCDD2,INDEX^ACKQCDD2
; if user wants values saved, then save them
D:ACKSAV SAVE^ACKQCDD2
;
; print the report
DEV W !!,"The right margin for this report is 80."
W !,"You can queue it to run at a later time.",!
K %ZIS,IOP S %ZIS="QM",%ZIS("B")="" D ^%ZIS
I POP W !,"NO DEVICE SELECTED OR REPORT PRINTED." G EXIT
; if queue selected then add job to queue
I $D(IO("Q")) D G EXIT
. K IO("Q")
. S ZTRTN="DQ^ACKQCDD",ZTDESC="QUASAR - Generate A&SP Service CDR"
. S ZTSAVE("ACK*")="",ZTSAVE("^TMP(""ACKQCDD"",$J,")=""
. D ^%ZTLOAD D HOME^%ZIS K ZTSK
;
DQ ; entry point if queued
U IO
D NOW^%DTC
S ACKPDT=$$NUMDT^ACKQUTL(%)_" at "_$$FTIME^ACKQUTL(%),ACKPG=0
D PRINT^ACKQCDD3
;
EXIT ; always exit here
K ACK2,ACKCAT,ACKCATI,ACKCDZ,ACKED,ACKFLAT,ACKIC,ACKLAYGO,ACKMO,ACKPDT
K ACKPG,ACKRTH,ACKSAV,ACKSD,ACKTCH,ACKTP,ACKTPH,ACKTSH,ACKXRNG,ACKDIV
K %,%I,%ZIS,CDR,D,D0,DA,DIC,DIE,DI,DIK,DIR,DIRUT,DQ,DR,DTOUT,DUOUT
K HD,I,M,NEWHD,SUB,X,X1,X2,Y,YN,ZTDESC,ZTRTN,ZTSAVE,ZTSK
K ACKQCDR,ACKVDIV,ACKCDRN,DLAYGO,ACKDIVX
K ^TMP("ACKQCDD",$J)
D:$E(IOST)="C" PAUSE^ACKQUTL D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
; W:$E(IOST)="C" @IOF D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
Q
SAVE ;
N DIR,X,Y
SAVE2 K DTOUT,DUOUT,DIRUT,DIR
S DIR(0)="Y",DIR("A")="Save Report Data",DIR("B")="YES"
S DIR("?")="Answer YES or NO.",DIR("??")="^D SAVE^ACKQCDD1"
D ^DIR K DTOUT,DUOUT
I Y?1"^"1.E W !,"Jumping not allowed.",! G SAVE2
S ACKSAV=Y
Q
DATES ;
N DIR,X,Y
I ACKSAV D MONTH Q
DATES2 K DTOUT,DUOUT,DIRUT,DIR
S DIR(0)="SB^M:MONTH;D:DATE RANGE",DIR("B")="M"
S DIR("A")="Generate CDR for a (M)onth or a (D)ate Range"
S DIR("?")="Enter 'M' for MONTH or 'D' for DATE RANGE."
S DIR("??")="^D DATES^ACKQCDD1"
D ^DIR K DIR
I Y?1"^"1.E W !,"Jumping not allowed.",! G DATES2
Q:$D(DIRUT)
I Y="D" D RANGE Q
MONTH S DIR(0)="D^::AEP",DIR("A")="Select Month and Year",DIR("B")=$$LM
S DIR("?")="^D HELP^%DTC",DIR("??")="^D MONTH^ACKQCDD1"
D ^DIR
I Y?1"^"1.E W !,"Jumping not allowed.",! G MONTH
Q:$D(DIRUT)
I '$E(Y,4,5) W !,$C(7),"Month Required!" G MONTH
I Y>DT W !,$C(7),"Can't run for future dates!",! G MONTH
S ACKSD=$E(Y,1,5)_"01",ACKED=$E(Y,1,5)_$$LD(Y),ACKMO=$E(Y,1,5)_"00"
S ACKXRNG=$$XDAT^ACKQUTL(ACKMO)
Q
RANGE ;
S DIR(0)="D^::AEXP",DIR("A")="Select Starting Date"
S DIR("?")="^D HELP^%DTC",DIR("??")="^D STARTD^ACKQCDD1"
D ^DIR K DIR
I Y?1"^"1.E W !,"Jumping not allowed.",! G RANGE
Q:$D(DIRUT)
I Y>DT W !,$C(7),"Can't run for future dates!",! G RANGE
S ACKMO="",ACKSD=Y,ACKXRNG=$$XDAT^ACKQUTL(Y)_" to "
ENDD S DIR(0)="D^::AEXP",DIR("A")="Select Ending Date"
S DIR("?")="^D HELP^%DTC",DIR("??")="^D ENDD^ACKQCDD1"
D ^DIR K DIR
I Y?1"^"1.E W !,"Jumping not allowed.",! G ENDD
Q:$D(DIRUT)
I Y>DT W !,"Can't run for future dates!",! G ENDD
I Y<ACKSD W !,"Can't be before Start Date!",! G ENDD
S ACKED=Y,ACKXRNG=ACKXRNG_$$XDAT^ACKQUTL(Y)
Q
YNFLAT ;
N DIR,X,Y
YNFLAT2 K DTOUT,DUOUT,DIRUT,DIR
S DIR(0)="Y",DIR("B")="NO",DIR("?")="Answer YES or NO."
S DIR("A")="Want to enter flat number of hours for "_ACKCAT
S DIR("??")="^D FLAT^ACKQCDD1"
D ^DIR
I Y?1"^"1.E W !,"Jumping not allowed.",! G YNFLAT2
S ACKFLAT=+Y
Q
FNH ;
N DIR,X,Y
FNH2 K DTOUT,DUOUT,DIRUT
S DIR(0)="N^0:"_ACKRTH,DIR("A")="Enter Hours"
S DIR("?")="^W !!,""Enter the number of hours you wish to spread over all of"",!,""the "",ACKCAT,"" accounts."""
D ^DIR
I Y?1"^"1.E W !,"Jumping not allowed.",! G FNH2
Q:$D(DIRUT)
S ACKRTH=ACKRTH-Y D SPREAD(Y,ACKCATI)
Q
SPREAD(X,Y) ;
N C,I,ACKTMP,ACKCDZ
S (C,I)=0 F S I=$O(^ACK(509850,"AT",Y,I)) Q:'I S ACKCDZ=^ACK(509850,I,0) I +ACKCDZ'[.12 S C=C+1,ACKTMP(+ACKCDZ)=0
S I=0 F S I=$O(ACKTMP(I)) Q:'I S ^TMP("ACKQCDD",$J,"ACKH",I)=X/C
Q
LM() ;RETURN EXTERNAL VALUE OF LAST MONTH
N X
S X(1)=$E(DT,1,3),X(2)=$E(DT,4,5)-1
I 'X(2) S X(2)=12,X(1)=X(1)-1
S X(2)=$$PAD^ACKQUTL(X(2),"R",2,"0") Q $$XDAT^ACKQUTL(X(1)_X(2)_"00")
LD(M) ;RETURN LAST DATE OF MONTH M
N X,Y
S Y=$E(M,1,3)+1700,M=+$E(M,4,5),X="31^28^31^30^31^30^31^31^30^31^30^31"
S:(Y#4=0&(Y#100'=0))!(Y#100=0&(Y#400=0)) $P(X,U,2)=29 Q $P(X,U,M)
OK(YN) ;
N DIR,DUOUT,DTOUT,DIRUT
OK2 S DIR(0)="Y",DIR("B")="NO",DIR("A")="Is that ok"
S DIR("A",1)="There are no clinic hours for the specified date range!"
S DIR("?")="Answer YES to continue with CDR or NO to quit."
D ^DIR
I Y?1"^"1.E W !,"Jumping not allowed.",! G OK2
S:$D(DIRUT) Y=0
Q Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HACKQCDD 7280 printed Jun 11, 2024@22:18 Page 2
ACKQCDD ;AUG/JLTP BIR/PTD HCIOFO/AG -Generate A&SP Service CDR for a Division; [ 03/03/98 3:10 PM ]
+1 ;;3.0;QUASAR;;Feb 11, 2000
+2 ;Per VHA Directive 10-93-142, this routine SHOULD NOT be modified.
+3 ;
SITE ; check whether the CDR should be run for the site or for each Division
+1 SET ACKQCDR=$$GET1^DIQ(509850.8,"1,",.1,"I")
+2 ; parameter not set to Division
IF ACKQCDR'="D"
GOTO EXIT
+3 ;
OPTN ;Introduce option.
+1 WRITE @IOF,!,"This option generates and prints the Audiology and"
+2 WRITE !,"Speech Pathology Service Cost Distribution Report"
+3 WRITE !,"for a single Division.",!
+4 ;
+5 KILL ^TMP("ACKQCDD",$JOB)
+6 ;
+7 ; prompt for Division
+8 SET ACKDIV=$$DIV^ACKQUTL2(1,.ACKDIVX,"AI")
+9 SET ACKDIV=$ORDER(ACKDIVX(""))
+10 ; if no division selected then exit
+11 IF +ACKDIV=0
GOTO EXIT
+12 ; ask if data is to be saved
+13 ; returns ACKSAV
+14 DO SAVE
if $DATA(DIRUT)
GOTO EXIT
+15 ; get the date range
+16 ; returns ACKSD and ACKED and ACKXRNG
+17 DO DATES
if $DATA(DIRUT)
GOTO EXIT
+18 ;
HRS ; calculate the total clinic hours
+1 DO CLINH^ACKQCDD2
+2 ; if no hours found, ask user if they want to proceed.
+3 IF '(ACKTCH+ACKTSH)
IF '$$OK
GOTO EXIT
+4 ;
+5 ; display total clinic hours and total student hours
+6 WRITE !!,"Total Clinic Hours for ",ACKXRNG,": ",$JUSTIFY((ACKTCH+ACKTSH),0,2)
+7 IF ACKTSH
Begin DoDot:1
+8 WRITE !,"Of that total, ",$JUSTIFY(ACKTSH,0,2)," hours are Instructional Support (.12)."
+9 WRITE !,"Remaining Clinic Hours: ",$JUSTIFY(ACKTCH,0,2)
End DoDot:1
+10 ;
+11 ; prompt for total paid hours
+12 DO TPH^ACKQCDD2
if $DATA(DIRUT)
GOTO EXIT
SET ACKRTH=ACKTPH
+13 ;
INPUT ;
+1 ; ask user for flat values for Admin Support and Cont Education
+2 SET ACKCATI="E"
SET ACKCAT="ADMIN SUPT (.13) & CONT ED (.14)"
+3 DO YNFLAT
if $DATA(DIRUT)
GOTO EXIT
+4 IF ACKFLAT
DO FNH
if $DATA(DIRUT)
GOTO EXIT
+5 IF 'ACKFLAT
Begin DoDot:1
+6 SET ACKIC=0
+7 FOR
SET ACKIC=$ORDER(^ACK(509850,"AT",ACKCATI,ACKIC))
if 'ACKIC
QUIT
Begin DoDot:2
+8 SET ACKCDZ=^ACK(509850,ACKIC,0)
+9 IF +ACKCDZ'[.12
DO INDCAT^ACKQCDD2(ACKIC)
if $DATA(DIRUT)
QUIT
End DoDot:2
if $DATA(DIRUT)
QUIT
End DoDot:1
if $DATA(DIRUT)
GOTO EXIT
+10 ;
+11 ; ask user for flat values for Research
+12 SET ACKCATI="R"
SET ACKCAT="RESEARCH"
+13 DO YNFLAT
if $DATA(DIRUT)
GOTO EXIT
+14 IF ACKFLAT
DO FNH
if $DATA(DIRUT)
GOTO EXIT
+15 IF 'ACKFLAT
Begin DoDot:1
+16 SET ACKIC=0
+17 FOR
SET ACKIC=$ORDER(^ACK(509850,"AT",ACKCATI,ACKIC))
if 'ACKIC
QUIT
Begin DoDot:2
+18 SET ACKCDZ=^ACK(509850,ACKIC,0)
+19 IF +ACKCDZ'[.12
DO INDCAT^ACKQCDD2(ACKIC)
if $DATA(DIRUT)
QUIT
End DoDot:2
if $DATA(DIRUT)
QUIT
End DoDot:1
if $DATA(DIRUT)
GOTO EXIT
+20 ;
PASS ; now do Pass-through accounts
+1 WRITE !!,"Now for pass through CDR accounts..."
+2 ;
+3 ; prompt for each pass-through account until user exits
+4 FOR
DO PASS^ACKQCDD2
IF $DATA(DIRUT)
KILL DIRUT
QUIT
+5 ;
+6 ; calculate remaining hours
+7 SET ACKRTH=ACKRTH-(ACKTCH+ACKTSH)
+8 ;
+9 ; check there are no remaining hours if there are no clinic hours left
+10 IF 'ACKTCH
IF ACKRTH
Begin DoDot:1
+11 WRITE !!,$CHAR(7),"You have hours remaining but no clinic visits to which they can be"
+12 WRITE !,"distributed! That won't work...",!!
End DoDot:1
GOTO EXIT
+13 ;
+14 ; distribute remaining hours
+15 IF ACKRTH
DO DISREM^ACKQCDD2
+16 ; convert values to percentages, index the file
+17 DO PERCENT^ACKQCDD2
DO INDEX^ACKQCDD2
+18 ; if user wants values saved, then save them
+19 if ACKSAV
DO SAVE^ACKQCDD2
+20 ;
+21 ; print the report
DEV WRITE !!,"The right margin for this report is 80."
+1 WRITE !,"You can queue it to run at a later time.",!
+2 KILL %ZIS,IOP
SET %ZIS="QM"
SET %ZIS("B")=""
DO ^%ZIS
+3 IF POP
WRITE !,"NO DEVICE SELECTED OR REPORT PRINTED."
GOTO EXIT
+4 ; if queue selected then add job to queue
+5 IF $DATA(IO("Q"))
Begin DoDot:1
+6 KILL IO("Q")
+7 SET ZTRTN="DQ^ACKQCDD"
SET ZTDESC="QUASAR - Generate A&SP Service CDR"
+8 SET ZTSAVE("ACK*")=""
SET ZTSAVE("^TMP(""ACKQCDD"",$J,")=""
+9 DO ^%ZTLOAD
DO HOME^%ZIS
KILL ZTSK
End DoDot:1
GOTO EXIT
+10 ;
DQ ; entry point if queued
+1 USE IO
+2 DO NOW^%DTC
+3 SET ACKPDT=$$NUMDT^ACKQUTL(%)_" at "_$$FTIME^ACKQUTL(%)
SET ACKPG=0
+4 DO PRINT^ACKQCDD3
+5 ;
EXIT ; always exit here
+1 KILL ACK2,ACKCAT,ACKCATI,ACKCDZ,ACKED,ACKFLAT,ACKIC,ACKLAYGO,ACKMO,ACKPDT
+2 KILL ACKPG,ACKRTH,ACKSAV,ACKSD,ACKTCH,ACKTP,ACKTPH,ACKTSH,ACKXRNG,ACKDIV
+3 KILL %,%I,%ZIS,CDR,D,D0,DA,DIC,DIE,DI,DIK,DIR,DIRUT,DQ,DR,DTOUT,DUOUT
+4 KILL HD,I,M,NEWHD,SUB,X,X1,X2,Y,YN,ZTDESC,ZTRTN,ZTSAVE,ZTSK
+5 KILL ACKQCDR,ACKVDIV,ACKCDRN,DLAYGO,ACKDIVX
+6 KILL ^TMP("ACKQCDD",$JOB)
+7 if $EXTRACT(IOST)="C"
DO PAUSE^ACKQUTL
DO ^%ZISC
if $DATA(ZTQUEUED)
SET ZTREQ="@"
+8 ; W:$E(IOST)="C" @IOF D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
+9 QUIT
SAVE ;
+1 NEW DIR,X,Y
SAVE2 KILL DTOUT,DUOUT,DIRUT,DIR
+1 SET DIR(0)="Y"
SET DIR("A")="Save Report Data"
SET DIR("B")="YES"
+2 SET DIR("?")="Answer YES or NO."
SET DIR("??")="^D SAVE^ACKQCDD1"
+3 DO ^DIR
KILL DTOUT,DUOUT
+4 IF Y?1"^"1.E
WRITE !,"Jumping not allowed.",!
GOTO SAVE2
+5 SET ACKSAV=Y
+6 QUIT
DATES ;
+1 NEW DIR,X,Y
+2 IF ACKSAV
DO MONTH
QUIT
DATES2 KILL DTOUT,DUOUT,DIRUT,DIR
+1 SET DIR(0)="SB^M:MONTH;D:DATE RANGE"
SET DIR("B")="M"
+2 SET DIR("A")="Generate CDR for a (M)onth or a (D)ate Range"
+3 SET DIR("?")="Enter 'M' for MONTH or 'D' for DATE RANGE."
+4 SET DIR("??")="^D DATES^ACKQCDD1"
+5 DO ^DIR
KILL DIR
+6 IF Y?1"^"1.E
WRITE !,"Jumping not allowed.",!
GOTO DATES2
+7 if $DATA(DIRUT)
QUIT
+8 IF Y="D"
DO RANGE
QUIT
MONTH SET DIR(0)="D^::AEP"
SET DIR("A")="Select Month and Year"
SET DIR("B")=$$LM
+1 SET DIR("?")="^D HELP^%DTC"
SET DIR("??")="^D MONTH^ACKQCDD1"
+2 DO ^DIR
+3 IF Y?1"^"1.E
WRITE !,"Jumping not allowed.",!
GOTO MONTH
+4 if $DATA(DIRUT)
QUIT
+5 IF '$EXTRACT(Y,4,5)
WRITE !,$CHAR(7),"Month Required!"
GOTO MONTH
+6 IF Y>DT
WRITE !,$CHAR(7),"Can't run for future dates!",!
GOTO MONTH
+7 SET ACKSD=$EXTRACT(Y,1,5)_"01"
SET ACKED=$EXTRACT(Y,1,5)_$$LD(Y)
SET ACKMO=$EXTRACT(Y,1,5)_"00"
+8 SET ACKXRNG=$$XDAT^ACKQUTL(ACKMO)
+9 QUIT
RANGE ;
+1 SET DIR(0)="D^::AEXP"
SET DIR("A")="Select Starting Date"
+2 SET DIR("?")="^D HELP^%DTC"
SET DIR("??")="^D STARTD^ACKQCDD1"
+3 DO ^DIR
KILL DIR
+4 IF Y?1"^"1.E
WRITE !,"Jumping not allowed.",!
GOTO RANGE
+5 if $DATA(DIRUT)
QUIT
+6 IF Y>DT
WRITE !,$CHAR(7),"Can't run for future dates!",!
GOTO RANGE
+7 SET ACKMO=""
SET ACKSD=Y
SET ACKXRNG=$$XDAT^ACKQUTL(Y)_" to "
ENDD SET DIR(0)="D^::AEXP"
SET DIR("A")="Select Ending Date"
+1 SET DIR("?")="^D HELP^%DTC"
SET DIR("??")="^D ENDD^ACKQCDD1"
+2 DO ^DIR
KILL DIR
+3 IF Y?1"^"1.E
WRITE !,"Jumping not allowed.",!
GOTO ENDD
+4 if $DATA(DIRUT)
QUIT
+5 IF Y>DT
WRITE !,"Can't run for future dates!",!
GOTO ENDD
+6 IF Y<ACKSD
WRITE !,"Can't be before Start Date!",!
GOTO ENDD
+7 SET ACKED=Y
SET ACKXRNG=ACKXRNG_$$XDAT^ACKQUTL(Y)
+8 QUIT
YNFLAT ;
+1 NEW DIR,X,Y
YNFLAT2 KILL DTOUT,DUOUT,DIRUT,DIR
+1 SET DIR(0)="Y"
SET DIR("B")="NO"
SET DIR("?")="Answer YES or NO."
+2 SET DIR("A")="Want to enter flat number of hours for "_ACKCAT
+3 SET DIR("??")="^D FLAT^ACKQCDD1"
+4 DO ^DIR
+5 IF Y?1"^"1.E
WRITE !,"Jumping not allowed.",!
GOTO YNFLAT2
+6 SET ACKFLAT=+Y
+7 QUIT
FNH ;
+1 NEW DIR,X,Y
FNH2 KILL DTOUT,DUOUT,DIRUT
+1 SET DIR(0)="N^0:"_ACKRTH
SET DIR("A")="Enter Hours"
+2 SET DIR("?")="^W !!,""Enter the number of hours you wish to spread over all of"",!,""the "",ACKCAT,"" accounts."""
+3 DO ^DIR
+4 IF Y?1"^"1.E
WRITE !,"Jumping not allowed.",!
GOTO FNH2
+5 if $DATA(DIRUT)
QUIT
+6 SET ACKRTH=ACKRTH-Y
DO SPREAD(Y,ACKCATI)
+7 QUIT
SPREAD(X,Y) ;
+1 NEW C,I,ACKTMP,ACKCDZ
+2 SET (C,I)=0
FOR
SET I=$ORDER(^ACK(509850,"AT",Y,I))
if 'I
QUIT
SET ACKCDZ=^ACK(509850,I,0)
IF +ACKCDZ'[.12
SET C=C+1
SET ACKTMP(+ACKCDZ)=0
+3 SET I=0
FOR
SET I=$ORDER(ACKTMP(I))
if 'I
QUIT
SET ^TMP("ACKQCDD",$JOB,"ACKH",I)=X/C
+4 QUIT
LM() ;RETURN EXTERNAL VALUE OF LAST MONTH
+1 NEW X
+2 SET X(1)=$EXTRACT(DT,1,3)
SET X(2)=$EXTRACT(DT,4,5)-1
+3 IF 'X(2)
SET X(2)=12
SET X(1)=X(1)-1
+4 SET X(2)=$$PAD^ACKQUTL(X(2),"R",2,"0")
QUIT $$XDAT^ACKQUTL(X(1)_X(2)_"00")
LD(M) ;RETURN LAST DATE OF MONTH M
+1 NEW X,Y
+2 SET Y=$EXTRACT(M,1,3)+1700
SET M=+$EXTRACT(M,4,5)
SET X="31^28^31^30^31^30^31^31^30^31^30^31"
+3 if (Y#4=0&(Y#100'=0))!(Y#100=0&(Y#400=0))
SET $PIECE(X,U,2)=29
QUIT $PIECE(X,U,M)
OK(YN) ;
+1 NEW DIR,DUOUT,DTOUT,DIRUT
OK2 SET DIR(0)="Y"
SET DIR("B")="NO"
SET DIR("A")="Is that ok"
+1 SET DIR("A",1)="There are no clinic hours for the specified date range!"
+2 SET DIR("?")="Answer YES to continue with CDR or NO to quit."
+3 DO ^DIR
+4 IF Y?1"^"1.E
WRITE !,"Jumping not allowed.",!
GOTO OK2
+5 if $DATA(DIRUT)
SET Y=0
+6 QUIT Y
