| [613] | 1 | ACKQCDD ;AUG/JLTP BIR/PTD HCIOFO/AG -Generate A&SP Service CDR for a Division; [ 03/03/98 3:10 PM ]
|
|---|
| 2 | ;;3.0;QUASAR;;Feb 11, 2000
|
|---|
| 3 | ;Per VHA Directive 10-93-142, this routine SHOULD NOT be modified.
|
|---|
| 4 | ;
|
|---|
| 5 | SITE ; check whether the CDR should be run for the site or for each Division
|
|---|
| 6 | S ACKQCDR=$$GET1^DIQ(509850.8,"1,",.1,"I")
|
|---|
| 7 | I ACKQCDR'="D" G EXIT ; parameter not set to Division
|
|---|
| 8 | ;
|
|---|
| 9 | OPTN ;Introduce option.
|
|---|
| 10 | W @IOF,!,"This option generates and prints the Audiology and"
|
|---|
| 11 | W !,"Speech Pathology Service Cost Distribution Report"
|
|---|
| 12 | W !,"for a single Division.",!
|
|---|
| 13 | ;
|
|---|
| 14 | K ^TMP("ACKQCDD",$J)
|
|---|
| 15 | ;
|
|---|
| 16 | ; prompt for Division
|
|---|
| 17 | S ACKDIV=$$DIV^ACKQUTL2(1,.ACKDIVX,"AI")
|
|---|
| 18 | S ACKDIV=$O(ACKDIVX(""))
|
|---|
| 19 | ; if no division selected then exit
|
|---|
| 20 | I +ACKDIV=0 G EXIT
|
|---|
| 21 | ; ask if data is to be saved
|
|---|
| 22 | ; returns ACKSAV
|
|---|
| 23 | D SAVE G:$D(DIRUT) EXIT
|
|---|
| 24 | ; get the date range
|
|---|
| 25 | ; returns ACKSD and ACKED and ACKXRNG
|
|---|
| 26 | D DATES G:$D(DIRUT) EXIT
|
|---|
| 27 | ;
|
|---|
| 28 | HRS ; calculate the total clinic hours
|
|---|
| 29 | D CLINH^ACKQCDD2
|
|---|
| 30 | ; if no hours found, ask user if they want to proceed.
|
|---|
| 31 | I '(ACKTCH+ACKTSH),'$$OK G EXIT
|
|---|
| 32 | ;
|
|---|
| 33 | ; display total clinic hours and total student hours
|
|---|
| 34 | W !!,"Total Clinic Hours for ",ACKXRNG,": ",$J((ACKTCH+ACKTSH),0,2)
|
|---|
| 35 | I ACKTSH D
|
|---|
| 36 | . W !,"Of that total, ",$J(ACKTSH,0,2)," hours are Instructional Support (.12)."
|
|---|
| 37 | . W !,"Remaining Clinic Hours: ",$J(ACKTCH,0,2)
|
|---|
| 38 | ;
|
|---|
| 39 | ; prompt for total paid hours
|
|---|
| 40 | D TPH^ACKQCDD2 G:$D(DIRUT) EXIT S ACKRTH=ACKTPH
|
|---|
| 41 | ;
|
|---|
| 42 | INPUT ;
|
|---|
| 43 | ; ask user for flat values for Admin Support and Cont Education
|
|---|
| 44 | S ACKCATI="E",ACKCAT="ADMIN SUPT (.13) & CONT ED (.14)"
|
|---|
| 45 | D YNFLAT G:$D(DIRUT) EXIT
|
|---|
| 46 | I ACKFLAT D FNH G:$D(DIRUT) EXIT
|
|---|
| 47 | I 'ACKFLAT D G:$D(DIRUT) EXIT
|
|---|
| 48 | .S ACKIC=0
|
|---|
| 49 | .F S ACKIC=$O(^ACK(509850,"AT",ACKCATI,ACKIC)) Q:'ACKIC D Q:$D(DIRUT)
|
|---|
| 50 | ..S ACKCDZ=^ACK(509850,ACKIC,0)
|
|---|
| 51 | ..I +ACKCDZ'[.12 D INDCAT^ACKQCDD2(ACKIC) Q:$D(DIRUT)
|
|---|
| 52 | ;
|
|---|
| 53 | ; ask user for flat values for Research
|
|---|
| 54 | S ACKCATI="R",ACKCAT="RESEARCH"
|
|---|
| 55 | D YNFLAT G:$D(DIRUT) EXIT
|
|---|
| 56 | I ACKFLAT D FNH G:$D(DIRUT) EXIT
|
|---|
| 57 | I 'ACKFLAT D G:$D(DIRUT) EXIT
|
|---|
| 58 | .S ACKIC=0
|
|---|
| 59 | .F S ACKIC=$O(^ACK(509850,"AT",ACKCATI,ACKIC)) Q:'ACKIC D Q:$D(DIRUT)
|
|---|
| 60 | ..S ACKCDZ=^ACK(509850,ACKIC,0)
|
|---|
| 61 | ..I +ACKCDZ'[.12 D INDCAT^ACKQCDD2(ACKIC) Q:$D(DIRUT)
|
|---|
| 62 | ;
|
|---|
| 63 | PASS ; now do Pass-through accounts
|
|---|
| 64 | W !!,"Now for pass through CDR accounts..."
|
|---|
| 65 | ;
|
|---|
| 66 | ; prompt for each pass-through account until user exits
|
|---|
| 67 | F D PASS^ACKQCDD2 I $D(DIRUT) K DIRUT Q
|
|---|
| 68 | ;
|
|---|
| 69 | ; calculate remaining hours
|
|---|
| 70 | S ACKRTH=ACKRTH-(ACKTCH+ACKTSH)
|
|---|
| 71 | ;
|
|---|
| 72 | ; check there are no remaining hours if there are no clinic hours left
|
|---|
| 73 | I 'ACKTCH,ACKRTH D G EXIT
|
|---|
| 74 | . W !!,$C(7),"You have hours remaining but no clinic visits to which they can be"
|
|---|
| 75 | . W !,"distributed! That won't work...",!!
|
|---|
| 76 | ;
|
|---|
| 77 | ; distribute remaining hours
|
|---|
| 78 | I ACKRTH D DISREM^ACKQCDD2
|
|---|
| 79 | ; convert values to percentages, index the file
|
|---|
| 80 | D PERCENT^ACKQCDD2,INDEX^ACKQCDD2
|
|---|
| 81 | ; if user wants values saved, then save them
|
|---|
| 82 | D:ACKSAV SAVE^ACKQCDD2
|
|---|
| 83 | ;
|
|---|
| 84 | ; print the report
|
|---|
| 85 | DEV W !!,"The right margin for this report is 80."
|
|---|
| 86 | W !,"You can queue it to run at a later time.",!
|
|---|
| 87 | K %ZIS,IOP S %ZIS="QM",%ZIS("B")="" D ^%ZIS
|
|---|
| 88 | I POP W !,"NO DEVICE SELECTED OR REPORT PRINTED." G EXIT
|
|---|
| 89 | ; if queue selected then add job to queue
|
|---|
| 90 | I $D(IO("Q")) D G EXIT
|
|---|
| 91 | . K IO("Q")
|
|---|
| 92 | . S ZTRTN="DQ^ACKQCDD",ZTDESC="QUASAR - Generate A&SP Service CDR"
|
|---|
| 93 | . S ZTSAVE("ACK*")="",ZTSAVE("^TMP(""ACKQCDD"",$J,")=""
|
|---|
| 94 | . D ^%ZTLOAD D HOME^%ZIS K ZTSK
|
|---|
| 95 | ;
|
|---|
| 96 | DQ ; entry point if queued
|
|---|
| 97 | U IO
|
|---|
| 98 | D NOW^%DTC
|
|---|
| 99 | S ACKPDT=$$NUMDT^ACKQUTL(%)_" at "_$$FTIME^ACKQUTL(%),ACKPG=0
|
|---|
| 100 | D PRINT^ACKQCDD3
|
|---|
| 101 | ;
|
|---|
| 102 | EXIT ; always exit here
|
|---|
| 103 | K ACK2,ACKCAT,ACKCATI,ACKCDZ,ACKED,ACKFLAT,ACKIC,ACKLAYGO,ACKMO,ACKPDT
|
|---|
| 104 | K ACKPG,ACKRTH,ACKSAV,ACKSD,ACKTCH,ACKTP,ACKTPH,ACKTSH,ACKXRNG,ACKDIV
|
|---|
| 105 | K %,%I,%ZIS,CDR,D,D0,DA,DIC,DIE,DI,DIK,DIR,DIRUT,DQ,DR,DTOUT,DUOUT
|
|---|
| 106 | K HD,I,M,NEWHD,SUB,X,X1,X2,Y,YN,ZTDESC,ZTRTN,ZTSAVE,ZTSK
|
|---|
| 107 | K ACKQCDR,ACKVDIV,ACKCDRN,DLAYGO,ACKDIVX
|
|---|
| 108 | K ^TMP("ACKQCDD",$J)
|
|---|
| 109 | D:$E(IOST)="C" PAUSE^ACKQUTL D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
|
|---|
| 110 | ; W:$E(IOST)="C" @IOF D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
|
|---|
| 111 | Q
|
|---|
| 112 | SAVE ;
|
|---|
| 113 | N DIR,X,Y
|
|---|
| 114 | SAVE2 K DTOUT,DUOUT,DIRUT,DIR
|
|---|
| 115 | S DIR(0)="Y",DIR("A")="Save Report Data",DIR("B")="YES"
|
|---|
| 116 | S DIR("?")="Answer YES or NO.",DIR("??")="^D SAVE^ACKQCDD1"
|
|---|
| 117 | D ^DIR K DTOUT,DUOUT
|
|---|
| 118 | I Y?1"^"1.E W !,"Jumping not allowed.",! G SAVE2
|
|---|
| 119 | S ACKSAV=Y
|
|---|
| 120 | Q
|
|---|
| 121 | DATES ;
|
|---|
| 122 | N DIR,X,Y
|
|---|
| 123 | I ACKSAV D MONTH Q
|
|---|
| 124 | DATES2 K DTOUT,DUOUT,DIRUT,DIR
|
|---|
| 125 | S DIR(0)="SB^M:MONTH;D:DATE RANGE",DIR("B")="M"
|
|---|
| 126 | S DIR("A")="Generate CDR for a (M)onth or a (D)ate Range"
|
|---|
| 127 | S DIR("?")="Enter 'M' for MONTH or 'D' for DATE RANGE."
|
|---|
| 128 | S DIR("??")="^D DATES^ACKQCDD1"
|
|---|
| 129 | D ^DIR K DIR
|
|---|
| 130 | I Y?1"^"1.E W !,"Jumping not allowed.",! G DATES2
|
|---|
| 131 | Q:$D(DIRUT)
|
|---|
| 132 | I Y="D" D RANGE Q
|
|---|
| 133 | MONTH S DIR(0)="D^::AEP",DIR("A")="Select Month and Year",DIR("B")=$$LM
|
|---|
| 134 | S DIR("?")="^D HELP^%DTC",DIR("??")="^D MONTH^ACKQCDD1"
|
|---|
| 135 | D ^DIR
|
|---|
| 136 | I Y?1"^"1.E W !,"Jumping not allowed.",! G MONTH
|
|---|
| 137 | Q:$D(DIRUT)
|
|---|
| 138 | I '$E(Y,4,5) W !,$C(7),"Month Required!" G MONTH
|
|---|
| 139 | I Y>DT W !,$C(7),"Can't run for future dates!",! G MONTH
|
|---|
| 140 | S ACKSD=$E(Y,1,5)_"01",ACKED=$E(Y,1,5)_$$LD(Y),ACKMO=$E(Y,1,5)_"00"
|
|---|
| 141 | S ACKXRNG=$$XDAT^ACKQUTL(ACKMO)
|
|---|
| 142 | Q
|
|---|
| 143 | RANGE ;
|
|---|
| 144 | S DIR(0)="D^::AEXP",DIR("A")="Select Starting Date"
|
|---|
| 145 | S DIR("?")="^D HELP^%DTC",DIR("??")="^D STARTD^ACKQCDD1"
|
|---|
| 146 | D ^DIR K DIR
|
|---|
| 147 | I Y?1"^"1.E W !,"Jumping not allowed.",! G RANGE
|
|---|
| 148 | Q:$D(DIRUT)
|
|---|
| 149 | I Y>DT W !,$C(7),"Can't run for future dates!",! G RANGE
|
|---|
| 150 | S ACKMO="",ACKSD=Y,ACKXRNG=$$XDAT^ACKQUTL(Y)_" to "
|
|---|
| 151 | ENDD S DIR(0)="D^::AEXP",DIR("A")="Select Ending Date"
|
|---|
| 152 | S DIR("?")="^D HELP^%DTC",DIR("??")="^D ENDD^ACKQCDD1"
|
|---|
| 153 | D ^DIR K DIR
|
|---|
| 154 | I Y?1"^"1.E W !,"Jumping not allowed.",! G ENDD
|
|---|
| 155 | Q:$D(DIRUT)
|
|---|
| 156 | I Y>DT W !,"Can't run for future dates!",! G ENDD
|
|---|
| 157 | I Y<ACKSD W !,"Can't be before Start Date!",! G ENDD
|
|---|
| 158 | S ACKED=Y,ACKXRNG=ACKXRNG_$$XDAT^ACKQUTL(Y)
|
|---|
| 159 | Q
|
|---|
| 160 | YNFLAT ;
|
|---|
| 161 | N DIR,X,Y
|
|---|
| 162 | YNFLAT2 K DTOUT,DUOUT,DIRUT,DIR
|
|---|
| 163 | S DIR(0)="Y",DIR("B")="NO",DIR("?")="Answer YES or NO."
|
|---|
| 164 | S DIR("A")="Want to enter flat number of hours for "_ACKCAT
|
|---|
| 165 | S DIR("??")="^D FLAT^ACKQCDD1"
|
|---|
| 166 | D ^DIR
|
|---|
| 167 | I Y?1"^"1.E W !,"Jumping not allowed.",! G YNFLAT2
|
|---|
| 168 | S ACKFLAT=+Y
|
|---|
| 169 | Q
|
|---|
| 170 | FNH ;
|
|---|
| 171 | N DIR,X,Y
|
|---|
| 172 | FNH2 K DTOUT,DUOUT,DIRUT
|
|---|
| 173 | S DIR(0)="N^0:"_ACKRTH,DIR("A")="Enter Hours"
|
|---|
| 174 | S DIR("?")="^W !!,""Enter the number of hours you wish to spread over all of"",!,""the "",ACKCAT,"" accounts."""
|
|---|
| 175 | D ^DIR
|
|---|
| 176 | I Y?1"^"1.E W !,"Jumping not allowed.",! G FNH2
|
|---|
| 177 | Q:$D(DIRUT)
|
|---|
| 178 | S ACKRTH=ACKRTH-Y D SPREAD(Y,ACKCATI)
|
|---|
| 179 | Q
|
|---|
| 180 | SPREAD(X,Y) ;
|
|---|
| 181 | N C,I,ACKTMP,ACKCDZ
|
|---|
| 182 | 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
|
|---|
| 183 | S I=0 F S I=$O(ACKTMP(I)) Q:'I S ^TMP("ACKQCDD",$J,"ACKH",I)=X/C
|
|---|
| 184 | Q
|
|---|
| 185 | LM() ;RETURN EXTERNAL VALUE OF LAST MONTH
|
|---|
| 186 | N X
|
|---|
| 187 | S X(1)=$E(DT,1,3),X(2)=$E(DT,4,5)-1
|
|---|
| 188 | I 'X(2) S X(2)=12,X(1)=X(1)-1
|
|---|
| 189 | S X(2)=$$PAD^ACKQUTL(X(2),"R",2,"0") Q $$XDAT^ACKQUTL(X(1)_X(2)_"00")
|
|---|
| 190 | LD(M) ;RETURN LAST DATE OF MONTH M
|
|---|
| 191 | N X,Y
|
|---|
| 192 | 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"
|
|---|
| 193 | S:(Y#4=0&(Y#100'=0))!(Y#100=0&(Y#400=0)) $P(X,U,2)=29 Q $P(X,U,M)
|
|---|
| 194 | OK(YN) ;
|
|---|
| 195 | N DIR,DUOUT,DTOUT,DIRUT
|
|---|
| 196 | OK2 S DIR(0)="Y",DIR("B")="NO",DIR("A")="Is that ok"
|
|---|
| 197 | S DIR("A",1)="There are no clinic hours for the specified date range!"
|
|---|
| 198 | S DIR("?")="Answer YES to continue with CDR or NO to quit."
|
|---|
| 199 | D ^DIR
|
|---|
| 200 | I Y?1"^"1.E W !,"Jumping not allowed.",! G OK2
|
|---|
| 201 | S:$D(DIRUT) Y=0
|
|---|
| 202 | Q Y
|
|---|
