source: WorldVistAEHR/trunk/r/QUASAR-ACKQ/ACKQCD2.m@ 1661

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

initial load of WorldVistAEHR
File size: 5.1 KB
RevLine 
[613]1ACKQCD2 ;AUG/JLTP BIR/PTD HCIOFO/AG-Generate A&SP Service CDR - CONTINUED ; [05/15/96 9:30 ]
2 ;;3.0;QUASAR;;Feb 11, 2000
3 ;Per VHA Directive 10-93-142, this routine SHOULD NOT be modified.
4INDCAT(ACKCDR) ;Enter hours for CDR account.
5 N DIR,Y,CDR,X
6INDCAT2 K DIRUT,DUOUT,DTOUT,DIR S X=ACKCDR
7 S DIR(0)="N^0:"_ACKRTH,CDR=$P(^ACK(509850,X,0),U)_" "_$P(^(0),U,2)
8 S DIR("A")="Enter Hours for "_CDR
9 S DIR("??")="^W !!,""Enter the number of hours that you wish to charge to CDR"",!,""account "",CDR,""."""
10 D ^DIR
11 I Y?1"^"1.E W !,"Jumping not allowed.",! G INDCAT2
12 Q:$D(DIRUT)
13 S ^TMP("ACKQCDR",$J,"ACKH",+CDR)=Y,ACKRTH=ACKRTH-Y
14 Q
15PASS ;Enter hours for pass-through account.
16 N DIC,DIR,X,Y,CDR
17PASS2 S DIC="^ACK(509850,",DIC("A")="Select Pass-Through Account: "
18 S DIC("S")="I $P(^(0),U,3)=""P""",DIC(0)="AEMQZ"
19 D ^DIC K DIC
20 I X?1"^"1.E W !,"Jumping not allowed.",! G PASS2
21 I Y<0 S DIRUT=1 Q
22 S CDR=+$P(Y,U,2),CDR(0)=$P(Y(0),U,2)
23PASS3 I $D(^TMP("ACKQCDR",$J,"ACKH",CDR)) S DIR("B")=^TMP("ACKQCDR",$J,"ACKH",CDR)
24 S DIR(0)="N^0:"_ACKRTH,DIR("A")="Enter Hours for "_CDR(0)
25 S DIR("??")="^W !!,""Enter the number of hours to charge to "",CDR(0)"
26 D ^DIR
27 I Y?1"^"1.E W !,"Jumping not allowed.",! G PASS3
28 Q:$D(DIRUT)
29 S ^TMP("ACKQCDR",$J,"ACKH",CDR)=Y S:$D(DIR("B")) ACKRTH=ACKRTH+DIR("B") S ACKRTH=ACKRTH-Y
30 Q
31DISREM ;DISTRIBUTE REMAINING HOURS
32 N I,X
33 S I=0 F S I=$O(ACKTCH(I)) Q:'I D
34 .S X=(ACKTCH(I)/ACKTCH)*ACKRTH,ACKTCH(I)=ACKTCH(I)+X
35 Q
36PERCENT ;CONVERT ALL VALUES TO %
37 N I,X
38 S ACKTP=0
39 S I=0 F S I=$O(^TMP("ACKQCDR",$J,"ACKH",I)) Q:'I S X=^TMP("ACKQCDR",$J,"ACKH",I)/ACKTPH*100,^TMP("ACKQCDR",$J,"ACKH",I)=X,ACKTP=ACKTP+X
40 S I=0 F S I=$O(ACKTCH(I)) Q:'I S ^TMP("ACKQCDR",$J,"ACKH",I)=ACKTCH(I)/ACKTPH*100,ACKTP=ACKTP+^TMP("ACKQCDR",$J,"ACKH",I)
41 K ACKTCH Q
42CLINH ;Calculate number of clinic hours & student training (.12) by CDR series. See README at end.
43 N C,D,I,V
44 K ACKTCH,ACKTSH S (ACKTCH,ACKTSH)=0
45 ;Loop through selected date range.
46 F D=(ACKSD-.1):0 S D=$O(^ACK(509850.6,"B",D)) Q:'D!(D>(ACKED+.9)) D
47 .S V=0 F S V=$O(^ACK(509850.6,"B",D,V)) Q:'V D
48 ..;Get TIME SPENT and CDR#. Student present? YES, increment ACKTSH array; else increment ACKTCH array.
49 ..S M=+$P(^ACK(509850.6,V,0),U,7),ACK2=^(2),C=+$P($G(ACK2),U,2),C=+$G(^ACK(509850,C,0))
50 ..I $P(ACK2,U,4) S ACKTSH=ACKTSH+M,ACKTSH($E(C,1,2))=$G(ACKTSH($E(C,1,2)))+M
51 ..I '$P(ACK2,U,4) S ACKTCH=ACKTCH+M,ACKTCH(C)=$G(ACKTCH(C))+M
52 ;Convert minutes to hours.
53 S ACKTCH=ACKTCH/60 S C=0 F S C=$O(ACKTCH(C)) Q:'C S ACKTCH(C)=ACKTCH(C)/60
54 S ACKTSH=ACKTSH/60 S C=0 F S C=$O(ACKTSH(C)) Q:'C S ACKTSH(C)=ACKTSH(C)/60
55 ;Move student hours array into ^TMP global.
56 S I=0 F S I=$O(ACKTSH(I)) Q:'I S ^TMP("ACKQCDR",$J,"ACKH",$S(((I<21)!(I>27)):I_"00.12",1:2800.12))=+ACKTSH(I)
57 Q
58TPH ;Ask for Total Paid Hours.
59 N DIR,X,Y
60TPH2 K DTOUT,DUOUT,DIRUT,DIR
61 S DIR(0)="N^1:9999",DIR("A")="Enter Total Paid Hours"
62 S DIR("?")="Enter a number between 1 and 9999."
63 S DIR("??")="^D TPH^ACKQCD1"
64 W ! D ^DIR
65 I Y?1"^"1.E W !,"Jumping not allowed.",! G TPH2
66 S ACKTPH=+Y
67 Q
68INDEX ;Build ^TMP arrays in category and CDR# order.
69 N I,CAT,CDR
70 S I=0 F S I=$O(^ACK(509850,I)) Q:'I S CDR=^(I,0),CAT=$P(CDR,U,4),^TMP("ACKQCDR",$J,"ACKCAT",CAT,+CDR)=$P(CDR,U,1,2) S:ACKSAV ^TMP("ACKQCDR",$J,"ACKNDX",+CDR)=$P(CDR,U)
71 Q
72SAVE ;
73 N IFN,M
74 S IFN=+$$SITE^VASITE_$E(ACKMO,1,5)
75 I $O(^ACK(509850.7,IFN,4,0)) D Q:$D(DIRUT)
76 .K DIR,X,Y S DIR(0)="Y",DIR("A")="Delete existing CDR data and regenerate the CDR for "_ACKXRNG,DIR("B")="NO"
77 .S DIR("?")="Enter YES to delete and regenerate the CDR, otherwise enter NO.",DIR("??")="^D REGEN^ACKQHLP1"
78 .W ! D ^DIR K DIR S:Y=0 DIRUT=1 Q:$D(DIRUT)
79DIK .;User wants to delete CDR subfile for date.
80 .S DIK="^ACK(509850.7,"_IFN_",4,",DA(1)=IFN S SUB=0
81 .F S SUB=$O(^ACK(509850.7,IFN,4,SUB)) Q:'SUB S DA=SUB D ^DIK
82 .S DIE="^ACK(509850.7,",DA=IFN,DR=".09///"_"@" D ^DIE K DIE,DA,DR
83 .; changed to check for Division level data before removing the month node
84 .I '$O(^ACK(509850.7,IFN,1,0)),'$D(^ACK(509850.7,IFN,5)) S DIK="^ACK(509850.7,",DA=IFN D ^DIK
85 L +^ACK(509850.7,IFN) D:'$D(^ACK(509850.7,IFN,0)) CREATE
86 S DIE="^ACK(509850.7,",DA=IFN,DR=".09////"_ACKTPH D ^DIE K DIE,DA,DR
87 S CDR=0 F S CDR=$O(^TMP("ACKQCDR",$J,"ACKH",CDR)) Q:'CDR I ^TMP("ACKQCDR",$J,"ACKH",CDR) D
88 .S DIC="^ACK(509850.7,"_IFN_",4,",DIC(0)="L",DLAYGO=509850.7,X=$P(^TMP("ACKQCDR",$J,"ACKNDX",CDR),U),DINUM=+X
89 .S DIC("P")=$P(^DD(509850.7,4,0),U,2),DA(1)=IFN K DD,DO D FILE^DICN K DA
90 .S DIE="^ACK(509850.7,"_IFN_",4,",DA=+CDR,DR=".02////"_$J(^TMP("ACKQCDR",$J,"ACKH",+CDR),0,9)
91 .D ^DIE
92 L -^ACK(509850.7,IFN)
93 Q
94CREATE ;
95 N DIC,DINUM,CDR,DD,DO
96 S DIC="^ACK(509850.7,",DIC(0)="L",DLAYGO=509850.7,ACKLAYGO="",X=ACKMO,DINUM=IFN D FILE^DICN
97 Q
98README ;Instructional Support (.12) Calculation:
99 ;As per Dr. Kyle Dennis 5/13/96. First 2 digits of CDR#
100 ;identify most CDR categories. 11-Medical, 12-Surgical,
101 ;13-Psych, 14-NH, 15-Dom Care, 16-Inter. Care, 17-Psych Rehab.
102 ;The CDR to be credited is: First 2 digits_"00.12"
103 ;CDR range 2110 through 2780 is Outpatient Care 2800.12.
104 ;If site uses 5100 HBHC, site must add 5100.12 to CDR file.
105 ;If site uses 8024 DOD SHARE, site must add 8000.12 to CDR file.
106 ;Ignore CATEGORY 11 and 12 from CDR file (#509850).
Note: See TracBrowser for help on using the repository browser.