source: WorldVistAEHR/trunk/r/QUASAR-ACKQ/ACKQCDR.m@ 724

Last change on this file since 724 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 5.5 KB
Line 
1ACKQCDR ;AUG/JLTP BIR/PTD HCIOFO/AG -Generate A&SP Service CDR ; [ 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 ;
5SITE ; 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'="S" G ^ACKQCDD ; generate for a single Division
8 ;
9OPTN ;Introduce option.
10 W @IOF,!,"This option generates and prints the Audiology and",!,"Speech Pathology Service Cost Distribution Report.",!
11 K ^TMP("ACKQCDR",$J) D SAVE G:$D(DIRUT) EXIT D DATES G:$D(DIRUT) EXIT
12HRS D CLINH^ACKQCD2 I '(ACKTCH+ACKTSH),'$$OK G EXIT
13 W !!,"Total Clinic Hours for ",ACKXRNG,": ",$J((ACKTCH+ACKTSH),0,2)
14 I ACKTSH W !,"Of that total, ",$J(ACKTSH,0,2)," hours are Instructional Support (.12).",!,"Remaining Clinic Hours: ",$J(ACKTCH,0,2)
15 D TPH^ACKQCD2 G:$D(DIRUT) EXIT S ACKRTH=ACKTPH
16INPUT F ACKCAT="E^ADMIN SUPT (.13) & CONT ED (.14)","R^RESEARCH" Q:$D(DIRUT) D
17 .S ACKCATI=$P(ACKCAT,U),ACKCAT=$P(ACKCAT,U,2)
18 .D YNFLAT Q:$D(DIRUT)
19 .I ACKFLAT D FNH Q:$D(DIRUT)
20 .I 'ACKFLAT D Q:$D(DIRUT)
21 ..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)
22 G:$D(DIRUT) EXIT
23PASS W !!,"Now for pass through CDR accounts..."
24 F D PASS^ACKQCD2 I $D(DIRUT) K DIRUT Q
25 S ACKRTH=ACKRTH-(ACKTCH+ACKTSH)
26 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
27 I ACKRTH D DISREM^ACKQCD2
28 D PERCENT^ACKQCD2,INDEX^ACKQCD2 D:ACKSAV SAVE^ACKQCD2
29DEV W !!,"The right margin for this report is 80.",!,"You can queue it to run at a later time.",!
30 K %ZIS,IOP S %ZIS="QM",%ZIS("B")="" D ^%ZIS I POP W !,"NO DEVICE SELECTED OR REPORT PRINTED." G EXIT
31 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
32DQ ;
33 U IO
34 D NOW^%DTC S ACKPDT=$$NUMDT^ACKQUTL(%)_" at "_$$FTIME^ACKQUTL(%),ACKPG=0
35 D PRINT^ACKQCD3
36EXIT ;
37 K ACK2,ACKCAT,ACKCATI,ACKCDZ,ACKED,ACKFLAT,ACKIC,ACKLAYGO,ACKMO,ACKPDT,ACKPG,ACKRTH,ACKSAV,ACKSD,ACKTCH,ACKTP,ACKTPH,ACKTSH,ACKXRNG
38 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)
39 K ACKQCDR
40 W:$E(IOST)'="C" @IOF D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
41 Q
42SAVE ;
43 N DIR,X,Y
44SAVE2 K DTOUT,DUOUT,DIRUT
45 S DIR(0)="Y",DIR("A")="Save Report Data",DIR("B")="YES"
46 S DIR("?")="Answer YES or NO.",DIR("??")="^D SAVE^ACKQCD1"
47 D ^DIR K DTOUT,DUOUT
48 I Y?1"^"1.E W !,"Jumping not allowed.",! G SAVE2
49 S ACKSAV=Y
50 Q
51DATES ;
52 N DIR,X,Y
53 I ACKSAV D MONTH Q
54DATES2 K DTOUT,DUOUT,DIRUT,DIR
55 S DIR(0)="SB^M:MONTH;D:DATE RANGE",DIR("B")="M"
56 S DIR("A")="Generate CDR for a (M)onth or a (D)ate Range"
57 S DIR("?")="Enter 'M' for MONTH or 'D' for DATE RANGE."
58 S DIR("??")="^D DATES^ACKQCD1"
59 D ^DIR K DIR
60 I Y?1"^"1.E W !,"Jumping not allowed.",! G DATES2
61 Q:$D(DIRUT)
62 I Y="D" D RANGE Q
63MONTH S DIR(0)="D^::AEP",DIR("A")="Select Month and Year",DIR("B")=$$LM
64 S DIR("?")="^D HELP^%DTC",DIR("??")="^D MONTH^ACKQCD1"
65 D ^DIR
66 I Y?1"^"1.E W !,"Jumping not allowed.",! G MONTH
67 Q:$D(DIRUT)
68 I '$E(Y,4,5) W !,$C(7),"Month Required!" G MONTH
69 I Y>DT W !,$C(7),"Can't run for future dates!",! G MONTH
70 S ACKSD=$E(Y,1,5)_"01",ACKED=$E(Y,1,5)_$$LD(Y),ACKMO=$E(Y,1,5)_"00"
71 S ACKXRNG=$$XDAT^ACKQUTL(ACKMO)
72 Q
73RANGE ;
74 S DIR(0)="D^::AEXP",DIR("A")="Select Starting Date"
75 S DIR("?")="^D HELP^%DTC",DIR("??")="^D STARTD^ACKQCD1"
76 D ^DIR K DIR
77 I Y?1"^"1.E W !,"Jumping not allowed.",! G RANGE
78 Q:$D(DIRUT)
79 I Y>DT W !,$C(7),"Can't run for future dates!",! G RANGE
80 S ACKMO="",ACKSD=Y,ACKXRNG=$$XDAT^ACKQUTL(Y)_" to "
81ENDD S DIR(0)="D^::AEXP",DIR("A")="Select Ending Date"
82 S DIR("?")="^D HELP^%DTC",DIR("??")="^D ENDD^ACKQCD1"
83 D ^DIR K DIR
84 I Y?1"^"1.E W !,"Jumping not allowed.",! G ENDD
85 Q:$D(DIRUT)
86 I Y>DT W !,"Can't run for future dates!",! G ENDD
87 I Y<ACKSD W !,"Can't be before Start Date!",! G ENDD
88 S ACKED=Y,ACKXRNG=ACKXRNG_$$XDAT^ACKQUTL(Y)
89 Q
90YNFLAT ;
91 N DIR,X,Y
92YNFLAT2 K DTOUT,DUOUT,DIRUT,DIR
93 S DIR(0)="Y",DIR("B")="NO",DIR("?")="Answer YES or NO."
94 S DIR("A")="Want to enter flat number of hours for "_ACKCAT
95 S DIR("??")="^D FLAT^ACKQCD1"
96 D ^DIR
97 I Y?1"^"1.E W !,"Jumping not allowed.",! G YNFLAT2
98 S ACKFLAT=+Y
99 Q
100FNH ;
101 N DIR,X,Y
102FNH2 K DTOUT,DUOUT,DIRUT,DIR
103 S DIR(0)="N^0:"_ACKRTH,DIR("A")="Enter Hours"
104 S DIR("?")="^W !!,""Enter the number of hours you wish to spread over all of"",!,""the "",ACKCAT,"" accounts."""
105 D ^DIR
106 I Y?1"^"1.E W !,"Jumping not allowed.",! G FNH2
107 Q:$D(DIRUT)
108 S ACKRTH=ACKRTH-Y D SPREAD(Y,ACKCATI)
109 Q
110SPREAD(X,Y) ;
111 N C,I,ACKTMP,ACKCDZ
112 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
113 S I=0 F S I=$O(ACKTMP(I)) Q:'I S ^TMP("ACKQCDR",$J,"ACKH",I)=X/C
114 Q
115LM() ;RETURN EXTERNAL VALUE OF LAST MONTH
116 N X
117 S X(1)=$E(DT,1,3),X(2)=$E(DT,4,5)-1
118 I 'X(2) S X(2)=12,X(1)=X(1)-1
119 S X(2)=$$PAD^ACKQUTL(X(2),"R",2,"0") Q $$XDAT^ACKQUTL(X(1)_X(2)_"00")
120LD(M) ;RETURN LAST DATE OF MONTH M
121 N X,Y
122 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"
123 S:(Y#4=0&(Y#100'=0))!(Y#100=0&(Y#400=0)) $P(X,U,2)=29 Q $P(X,U,M)
124OK(YN) ;
125 N DIR,DUOUT,DTOUT,DIRUT
126OK2 S DIR(0)="Y",DIR("B")="NO",DIR("A")="Is that ok"
127 S DIR("A",1)="There are no clinic hours for the specified date range!"
128 S DIR("?")="Answer YES to continue with CDR or NO to quit."
129 D ^DIR
130 I Y?1"^"1.E W !,"Jumping not allowed.",! G OK2
131 S:$D(DIRUT) Y=0
132 Q Y
Note: See TracBrowser for help on using the repository browser.