ACKQCDR.m

ACKQCDR ;AUG/JLTP BIR/PTD HCIOFO/AG -Generate A&SP Service CDR ; [ 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'="S" G ^ACKQCDD  ; generate for a single Division

 ;

OPTN ;Introduce option.

 W @IOF,!,"This option generates and prints the Audiology and",!,"Speech Pathology Service Cost Distribution Report.",!

 K ^TMP("ACKQCDR",$J) D SAVE G:$D(DIRUT) EXIT D DATES G:$D(DIRUT) EXIT

HRS D CLINH^ACKQCD2 I '(ACKTCH+ACKTSH),'$$OK G EXIT

 W !!,"Total Clinic Hours for ",ACKXRNG,": ",$J((ACKTCH+ACKTSH),0,2)

 I ACKTSH W !,"Of that total, ",$J(ACKTSH,0,2)," hours are Instructional Support (.12).",!,"Remaining Clinic Hours: ",$J(ACKTCH,0,2)

 D TPH^ACKQCD2 G:$D(DIRUT) EXIT S ACKRTH=ACKTPH

INPUT F ACKCAT="E^ADMIN SUPT (.13) & CONT ED (.14)","R^RESEARCH" Q:$D(DIRUT)  D

 .S ACKCATI=$P(ACKCAT,U),ACKCAT=$P(ACKCAT,U,2)

 .D YNFLAT Q:$D(DIRUT)

 .I ACKFLAT D FNH Q:$D(DIRUT)

 .I 'ACKFLAT D  Q:$D(DIRUT)

 ..S ACKIC=0 F  S ACKIC=$O(^ACK(509850,"AT",ACKCATI,ACKIC)) Q:'ACKIC  S ACKCDZ=^ACK(509850,ACKIC,0) I +ACKCDZ'[.12 D INDCAT^ACKQCD2(ACKIC) Q:$D(DIRUT)

 G:$D(DIRUT) EXIT

PASS W !!,"Now for pass through CDR accounts..."

 F  D PASS^ACKQCD2 I $D(DIRUT) K DIRUT Q

 S ACKRTH=ACKRTH-(ACKTCH+ACKTSH)

 I 'ACKTCH,ACKRTH W !!,$C(7),"You have hours remaining but no clinic visits to which they can be",!,"distributed!  That won't work...",!! G EXIT

 I ACKRTH D DISREM^ACKQCD2

 D PERCENT^ACKQCD2,INDEX^ACKQCD2 D:ACKSAV SAVE^ACKQCD2

DEV W !!,"The right margin for this report is 80.",!,"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

 I $D(IO("Q")) K IO("Q") S ZTRTN="DQ^ACKQCDR",ZTDESC="QUASAR - Generate A&SP Service CDR",ZTSAVE("ACK*")="",ZTSAVE("^TMP(""ACKQCDR"",$J,")="" D ^%ZTLOAD D HOME^%ZIS K ZTSK G EXIT

DQ ;

 U IO

 D NOW^%DTC S ACKPDT=$$NUMDT^ACKQUTL(%)_" at "_$$FTIME^ACKQUTL(%),ACKPG=0

 D PRINT^ACKQCD3

EXIT ;

 K ACK2,ACKCAT,ACKCATI,ACKCDZ,ACKED,ACKFLAT,ACKIC,ACKLAYGO,ACKMO,ACKPDT,ACKPG,ACKRTH,ACKSAV,ACKSD,ACKTCH,ACKTP,ACKTPH,ACKTSH,ACKXRNG

 K %,%I,%ZIS,CDR,D,D0,DA,DIC,DIE,DI,DIK,DIR,DIRUT,DQ,DR,DTOUT,DUOUT,HD,I,M,NEWHD,SUB,X,X1,X2,Y,YN,ZTDESC,ZTRTN,ZTSAVE,ZTSK,^TMP("ACKQCDR",$J)

 K ACKQCDR

 W:$E(IOST)'="C" @IOF D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"

 Q

SAVE ;

 N DIR,X,Y

SAVE2 K DTOUT,DUOUT,DIRUT

 S DIR(0)="Y",DIR("A")="Save Report Data",DIR("B")="YES"

 S DIR("?")="Answer YES or NO.",DIR("??")="^D SAVE^ACKQCD1"

 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^ACKQCD1"

 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^ACKQCD1"

 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^ACKQCD1"

 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^ACKQCD1"

 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^ACKQCD1"

 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,DIR

 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("ACKQCDR",$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 ---ACKQCDR   5735     printed  Mar 13, 2025@21:37:01                                                                                                                                                                                                     Page 2

ACKQCDR   ;AUG/JLTP BIR/PTD HCIOFO/AG -Generate A&SP Service CDR ; [ 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       ; generate for a single Division

           IF ACKQCDR'="S"

               GOTO ^ACKQCDD

 +3       ;

OPTN      ;Introduce option.

 +1        WRITE @IOF,!,"This option generates and prints the Audiology and",!,"Speech Pathology Service Cost Distribution Report.",!

 +2        KILL ^TMP("ACKQCDR",$JOB)

           DO SAVE

           if $DATA(DIRUT)

               GOTO EXIT

           DO DATES

           if $DATA(DIRUT)

               GOTO EXIT

HRS        DO CLINH^ACKQCD2

           IF '(ACKTCH+ACKTSH)

               IF '$$OK

                   GOTO EXIT

 +1        WRITE !!,"Total Clinic Hours for ",ACKXRNG,": ",$JUSTIFY((ACKTCH+ACKTSH),0,2)

 +2        IF ACKTSH

               WRITE !,"Of that total, ",$JUSTIFY(ACKTSH,0,2)," hours are Instructional Support (.12).",!,"Remaining Clinic Hours: ",$JUSTIFY(ACKTCH,0,2)

 +3        DO TPH^ACKQCD2

           if $DATA(DIRUT)

               GOTO EXIT

           SET ACKRTH=ACKTPH

INPUT      FOR ACKCAT="E^ADMIN SUPT (.13) & CONT ED (.14)","R^RESEARCH"

               if $DATA(DIRUT)

                   QUIT 

               Begin DoDot:1

 +1                SET ACKCATI=$PIECE(ACKCAT,U)

                   SET ACKCAT=$PIECE(ACKCAT,U,2)

 +2                DO YNFLAT

                   if $DATA(DIRUT)

                       QUIT 

 +3                IF ACKFLAT

                       DO FNH

                       if $DATA(DIRUT)

                           QUIT 

 +4                IF 'ACKFLAT

                       Begin DoDot:2

 +5                        SET ACKIC=0

                           FOR 

                               SET ACKIC=$ORDER(^ACK(509850,"AT",ACKCATI,ACKIC))

                               if 'ACKIC

                                   QUIT 

                               SET ACKCDZ=^ACK(509850,ACKIC,0)

                               IF +ACKCDZ'[.12

                                   DO INDCAT^ACKQCD2(ACKIC)

                                   if $DATA(DIRUT)

                                       QUIT 

                       End DoDot:2

                       if $DATA(DIRUT)

                           QUIT 

               End DoDot:1

 +6        if $DATA(DIRUT)

               GOTO EXIT

PASS       WRITE !!,"Now for pass through CDR accounts..."

 +1        FOR 

               DO PASS^ACKQCD2

               IF $DATA(DIRUT)

                   KILL DIRUT

                   QUIT 

 +2        SET ACKRTH=ACKRTH-(ACKTCH+ACKTSH)

 +3        IF 'ACKTCH

               IF ACKRTH

                   WRITE !!,$CHAR(7),"You have hours remaining but no clinic visits to which they can be",!,"distributed!  That won't work...",!!

                   GOTO EXIT

 +4        IF ACKRTH

               DO DISREM^ACKQCD2

 +5        DO PERCENT^ACKQCD2

           DO INDEX^ACKQCD2

           if ACKSAV

               DO SAVE^ACKQCD2

DEV        WRITE !!,"The right margin for this report is 80.",!,"You can queue it to run at a later time.",!

 +1        KILL %ZIS,IOP

           SET %ZIS="QM"

           SET %ZIS("B")=""

           DO ^%ZIS

           IF POP

               WRITE !,"NO DEVICE SELECTED OR REPORT PRINTED."

               GOTO EXIT

 +2        IF $DATA(IO("Q"))

               KILL IO("Q")

               SET ZTRTN="DQ^ACKQCDR"

               SET ZTDESC="QUASAR - Generate A&SP Service CDR"

               SET ZTSAVE("ACK*")=""

               SET ZTSAVE("^TMP(""ACKQCDR"",$J,")=""

               DO ^%ZTLOAD

               DO HOME^%ZIS

               KILL ZTSK

               GOTO EXIT

DQ        ;

 +1        USE IO

 +2        DO NOW^%DTC

           SET ACKPDT=$$NUMDT^ACKQUTL(%)_" at "_$$FTIME^ACKQUTL(%)

           SET ACKPG=0

 +3        DO PRINT^ACKQCD3

EXIT      ;

 +1        KILL ACK2,ACKCAT,ACKCATI,ACKCDZ,ACKED,ACKFLAT,ACKIC,ACKLAYGO,ACKMO,ACKPDT,ACKPG,ACKRTH,ACKSAV,ACKSD,ACKTCH,ACKTP,ACKTPH,ACKTSH,ACKXRNG

 +2        KILL %,%I,%ZIS,CDR,D,D0,DA,DIC,DIE,DI,DIK,DIR,DIRUT,DQ,DR,DTOUT,DUOUT,HD,I,M,NEWHD,SUB,X,X1,X2,Y,YN,ZTDESC,ZTRTN,ZTSAVE,ZTSK,^TMP("ACKQCDR",$JOB)

 +3        KILL ACKQCDR

 +4        if $EXTRACT(IOST)'="C"

               WRITE @IOF

           DO ^%ZISC

           if $DATA(ZTQUEUED)

               SET ZTREQ="@"

 +5        QUIT 

SAVE      ;

 +1        NEW DIR,X,Y

SAVE2      KILL DTOUT,DUOUT,DIRUT

 +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^ACKQCD1"

 +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^ACKQCD1"

 +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^ACKQCD1"

 +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^ACKQCD1"

 +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^ACKQCD1"

 +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^ACKQCD1"

 +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,DIR

 +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("ACKQCDR",$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