source: WorldVistAEHR/trunk/r/QUASAR-ACKQ/ACKQRU.m@ 1150

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

initial load of WorldVistAEHR
File size: 5.2 KB
RevLine 
[613]1ACKQRU ;AUG/JLTP BIR/PTD HCIOFO/AG-Support Routine for Reports ; [ 11/08/95 9:26 ]
2 ;;3.0;QUASAR;;Feb 11, 2000
3 ;Per VHA Directive 10-93-142, this routine SHOULD NOT be modified.
4DTRANGE ;
5BEGDT N ACKTMPB
6 S DIR(0)="D^:"_DT_":AEXP",DIR("A")="Beginning Date"
7 S DIR("?")="Enter the earliest date for which you want to see data"
8 S DIR("??")="^S ACKQHLP=1 D ^ACKQHLP"
9 D ^DIR K DIR
10 I Y?1"^"1.E W !,"Jumping not allowed.",! G BEGDT
11 Q:$D(DIRUT) S ACKBD=Y-.1,ACKXBD=$$NUMDT^ACKQUTL(Y),ACKTMPB=Y
12 ;
13ENDDT ; S DIR(0)="D^"_(ACKBD+.1)_":"_DT_":AEXP",DIR("A")="Ending Date"
14 S DIR(0)="D"
15 S DIR("A")="Ending Date"
16 S DIR("?")="Enter the latest date for which you want to see data"
17 S DIR("??")="^S ACKQHLP=1 D ^ACKQHLP"
18 D ^DIR K DIR
19 I Y?1"^"1.E W !,"Jumping not allowed.",! G ENDDT
20 Q:$D(DIRUT) S ACKED=Y+.9,ACKXED=$$NUMDT^ACKQUTL(Y)
21 I Y<ACKTMPB W !,"End date cannot be before the Begin date.",! G ENDDT
22 Q
23PARAMS ;
24 ; this subroutine contains two standard prompts
25 ; 1. Select a = AUDIOLOGY
26 ; s = SPEECH PATHOLOGY
27 ; b = BOTH
28 ; 2. Choose 1 = ONE CLINICIAN
29 ; 2 = ONE OTHER PROVIDER
30 ; 3 = ONE STUDENT
31 ; 4 = ALL CLINICIANS
32 ; 5 = ALL OTHER PROVIDERS
33 ; 6 = ALL STUDENTS
34 ; it returns
35 ; DIRUT=1 user chose to exit
36 ; ACKASB response to prompt 1
37 ; (A=audio, S=speech, B=Both)
38 ; ACKSS response to prompt 2 (1-6)
39 ; ACKSTF() array containing all selected staff
40 ; where ACKSTF(n)=persons IEN on NEW PERSON FILE
41 ;
42 N DIR,I,X,Y,DIC,ACKQHLP
43 ;
44 ; prompt 1
45 S DIR(0)="S^a:AUDIOLOGY;s:SPEECH PATHOLOGY;b:BOTH"
46 S DIR("A")="Select",DIR("B")="BOTH"
47 S DIR("??")="^W !!,""You can select Audiology visits, Speech Pathology visits, or Both."",!"
48 D ^DIR K DIR Q:$D(DIRUT)
49 S ACKASB=$S(Y="a":"A",Y="s":"S",1:"B")
50 ;
51 ; prompt 2
52 S DIR(0)="S^1:ONE CLINICIAN;2:ONE OTHER PROVIDER;3:ONE STUDENT;4:ALL CLINICIANS;5:ALL OTHER PROVIDERS;6:ALL STUDENTS"
53 S DIR("A")="Choose",DIR("??")="^S ACKQHLP=4 D ^ACKQHLP"
54 D ^DIR K DIR Q:$D(DIRUT)
55 S ACKSS=Y
56 K ACKSTF
57 ; if ONE staff member selected then ask for name
58 I ACKSS<4 D Q:$D(DIRUT)
59 . S DIC("A")="Select "_$S(ACKSS=1:"CLINICIAN",ACKSS=2:"OTHER PROVIDER",1:"STUDENT")_": "
60 . S DIC(0)="AEMQZ",DIC=509850.3
61 . S DIC("S")="I $P(^(0),U,2)]"""",$P(""CF^O^S"",U,ACKSS)[$P(^(0),U,2)"
62 . D ^DIC K DIC S:Y<0 DIRUT=1 Q:$D(DIRUT)
63 . S ACKSTF(+Y)=$P(Y,U,2)
64 ; if ALL staff selected then get them from staff file
65 I ACKSS>3 D
66 . S I=0 F S I=$O(^ACK(509850.3,I)) Q:'I D
67 . . S X=$P(^ACK(509850.3,I,0),U,2)
68 . . I X="" Q
69 . . I ACKSS=4,"CF"'[X Q
70 . . I ACKSS=5,X'="O" Q
71 . . I ACKSS=6,X'="S" Q
72 . . S ACKSTF(I)=$P(^ACK(509850.3,I,0),U)
73 ;
74 ; end
75 Q
76 ;
77GETDIV(DIVARR,ACKSTA,ACKOPT) ; get all the Divisions and put them in DIVARR
78 ; INPUT: DIVARR must be passed by reference
79 ; ACKSTA division status (optional)
80 ; 'A' will get active divisions only (default)
81 ; 'I' will get inactive divisions only
82 ; 'AI' or 'IA' will get all divisions
83 ; ACKOPT options. so far the only option is 'U' to output the
84 ; names in uppercase.
85 ; RETURNS: DIVARR= number found (n)
86 ; DIVARR(1,n)=x^y^name
87 ; DIVARR(2,name)=n
88 ; and DIVARR(3,x)=n
89 ; where x=IEN of Div from Medical Center Division file
90 ; and y=sequence number from A&SP Site Parameter file
91 ; (in other words ^ACK(509850.8,1,2,y)=x^...)
92 ; and name=the division name
93 ;
94 N ACKTGT,ACKMSG,ACKSCRN,ACK,SEQ,DIV,DIVNAME
95 K DIVARR
96 ; build screen based on requested status
97 I $G(ACKSTA)="" S ACKSTA="A"
98 S ACKSCRN="I """_ACKSTA_"""[$P(^(0),U,2)"
99 ; go get 'em
100 D LIST^DIC(509850.83,",1,",".01","I","*","","","",ACKSCRN,"","ACKTGT","ACKMSG")
101 ; now transfer to output array
102 S DIVARR=$P(ACKTGT("DILIST",0),U,1)
103 FOR ACK=1:1:DIVARR D
104 . S SEQ=ACKTGT("DILIST",2,ACK),DIV=ACKTGT("DILIST",1,ACK)
105 . S DIVNAME=$$GET1^DIQ(40.8,DIV_",",.01)
106 . S DIVARR(1,ACK)=DIV_U_SEQ_U_DIVNAME
107 . S DIVARR(2,$$UP($G(ACKOPT),DIVNAME))=ACK
108 . S DIVARR(3,DIV)=ACK
109 Q
110UP(ACKOPT,X) ; convert X to uppercase (if requested)
111 I ACKOPT["U" Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
112 Q X
113 ;
114STOPSORT(ACKASB,ACKVSC) ; determine stop code sort value
115 ; this function determines whether the Stop Code for the Visit is
116 ; valid for the type of report selected.
117 ; If it is not valid the function returns 0
118 ; If it is valid the function returns an integer which may be used to
119 ; sequence the visit so that Audio comes first, Audio/Tel next,
120 ; then Speech and Speech/Tel.
121 ; If an unknown Visit Stop Code is encountered, it is given a 9
122 ; which means it will appear at the end of the report as UNKNOWN.
123 I ACKVSC="A" Q $S(ACKASB="A":1,ACKASB="B":1,1:0) ; audiology #1
124 I ACKVSC="AT" Q $S(ACKASB="A":2,ACKASB="B":2,1:0) ; telephone audiology #2
125 I ACKVSC="S" Q $S(ACKASB="S":3,ACKASB="B":3,1:0) ; speech #3
126 I ACKVSC="ST" Q $S(ACKASB="S":4,ACKASB="B":4,1:0) ; telephone speech #4
127 Q 9 ; any other value 9
128 ;
129STOPNM(ACKSORT) ; convert stop code sort value into a stop code name
130 I ACKSORT=1 Q "AUDIOLOGY"
131 I ACKSORT=2 Q "AUDIOLOGY TELEPHONE"
132 I ACKSORT=3 Q "SPEECH PATHOLOGY"
133 I ACKSORT=4 Q "SPEECH TELEPHONE"
134 Q "UNKNOWN"
135 ;
Note: See TracBrowser for help on using the repository browser.