- 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 Jan 18, 2025@03:33:06 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