| [613] | 1 | ACKQUTL2 ;AUG/JLTP BIR/PTD HCIOFO/AG -QUASAR Utility Routine ; [ 04/25/96 10:03 ]
|
|---|
| 2 | ;;3.0;QUASAR;**15**;Feb 11, 2000;Build 2
|
|---|
| 3 | ;Per VHA Directive 10-93-142, this routine SHOULD NOT be modified.
|
|---|
| 4 | ;
|
|---|
| 5 | ;
|
|---|
| 6 | DIVLIST(ACKTYP,ACKTXT) ; list on screen all the Divisions on the Site Parameter File
|
|---|
| 7 | ; optional ACKTYP = type of list 1=Active only, 0 (default) = all
|
|---|
| 8 | ; optional ACKTXT = preceding message
|
|---|
| 9 | N ACKFROM,ACKFDA,ACKMSG,ACKSCRN,DIWL,DIWR,DIWF,X,Y,I,DA,ACKCT
|
|---|
| 10 | S ACKFROM="",ACKTYP=$S(+$G(ACKTYP)=1:1,1:0)
|
|---|
| 11 | ; set up the screen if only active divisions are to be listed
|
|---|
| 12 | S ACKSCRN=$S(ACKTYP=1:"I $P(^(0),U,2)=""A""",1:"")
|
|---|
| 13 | ; call fileman to retrieve the Divisions
|
|---|
| 14 | D LIST^DIC(509850.83,",1,",".01;.02","","",.ACKFROM,"","",ACKSCRN,"","ACKFDA","ACKMSG")
|
|---|
| 15 | ; get count of number of Divisions
|
|---|
| 16 | S ACKCT=$P(ACKFDA("DILIST",0),U,1)
|
|---|
| 17 | ; determine the text header
|
|---|
| 18 | I ACKCT=0,ACKTYP=0 S ACKTXT=" No Divisions have been set up."
|
|---|
| 19 | I ACKCT=0,ACKTYP=1 S ACKTXT=" There are no Active Divisions on file."
|
|---|
| 20 | I $G(ACKTXT)="" D
|
|---|
| 21 | . I ACKCT>0 S ACKTXT=" The following Divisions have been set up..."
|
|---|
| 22 | ;
|
|---|
| 23 | ; the following section uses DIWP & DIWW to format and output the text
|
|---|
| 24 | S DIWL=5,DIWR=75,DIWF=""
|
|---|
| 25 | S X="|SETTAB(10,40)| " D ^DIWP
|
|---|
| 26 | S X=" " D ^DIWP ;blank line!
|
|---|
| 27 | S X=ACKTXT D ^DIWP
|
|---|
| 28 | ; now output each Division
|
|---|
| 29 | F ACK=1:1:ACKCT D
|
|---|
| 30 | . ; print division name
|
|---|
| 31 | . S X=" |TAB|"_$E(ACKFDA("DILIST",1,ACK),1,25)
|
|---|
| 32 | . ; if all divisions to be printed then also print the status
|
|---|
| 33 | . I ACKTYP=0 S X=X_"|TAB|"_$$MC(ACKFDA("DILIST","ID",ACK,.02))
|
|---|
| 34 | . D ^DIWP
|
|---|
| 35 | ; now write to the screen
|
|---|
| 36 | D ^DIWW
|
|---|
| 37 | ;
|
|---|
| 38 | ; end
|
|---|
| 39 | Q
|
|---|
| 40 | ;
|
|---|
| 41 | MC(X) ; convert X to mixed case (1st upper, remainder lower)
|
|---|
| 42 | N UP,LW S UP="ABCDEFGHIJKLMNOPQRSTUVWXYZ",LW="abcdefghijklmnopqrstuvwxyz"
|
|---|
| 43 | Q $TR($E(X),LW,UP)_$TR($E(X,2,999),UP,LW)
|
|---|
| 44 | ;
|
|---|
| 45 | ;
|
|---|
| 46 | DIV(ACKTYP,ACKDIV,ACKSTA) ; prompt user for an A&SP Division
|
|---|
| 47 | ; where ACKTYP can be 1=one div, 2=many, 3=many/all
|
|---|
| 48 | ; if ACTYPE>1 then ACKDIV must be passed in by reference
|
|---|
| 49 | ; and ACKSTA contains the required status of the Division
|
|---|
| 50 | ; so if ACKSTA="A" then only active divisions may be chosen
|
|---|
| 51 | ; if ACKSTA="I" then only inactive divisions may be chosen
|
|---|
| 52 | ; if ACKSTA="AI" or "IA" then either active or inactive may be
|
|---|
| 53 | ; chosen. If not passed then "A" is used as the default.
|
|---|
| 54 | ; ------------------------------------------------------------
|
|---|
| 55 | ; function returns:-
|
|---|
| 56 | ; ACKDIV=a^b where a=no. divisions selected, and b=total
|
|---|
| 57 | ; available divisions.
|
|---|
| 58 | ; (if the user quits or times out then a=0)
|
|---|
| 59 | ; ACKDIV(x)=x^y^z where
|
|---|
| 60 | ; x=div ien on Med Cen Div file #40.8,
|
|---|
| 61 | ; y=div ien on Site Parameters #509850.83
|
|---|
| 62 | ; and z=division name
|
|---|
| 63 | ; ------------------------------------------------------------
|
|---|
| 64 | N DIVARR,ACKDIVN,ACKN,ACKDEF,ACKDFLT,ACKIEN,ACKX
|
|---|
| 65 | K ACKDIV
|
|---|
| 66 | ; initialise selected Division
|
|---|
| 67 | S ACKDIV=""
|
|---|
| 68 | ;
|
|---|
| 69 | ; check parameter has been passed in
|
|---|
| 70 | I "1/2/3"'[+$G(ACKTYP) G DIVX
|
|---|
| 71 | ;
|
|---|
| 72 | ; get list of divisions
|
|---|
| 73 | D GETDIV^ACKQRU(.DIVARR,$G(ACKSTA),"U")
|
|---|
| 74 | ;
|
|---|
| 75 | ; no Divisions exist
|
|---|
| 76 | I DIVARR<1 S ACKDIV=0 G DIVX
|
|---|
| 77 | ;
|
|---|
| 78 | ; only one Division exists
|
|---|
| 79 | I DIVARR=1 D G DIVX
|
|---|
| 80 | . S ACKDIV="1^1",ACKDIV($P(DIVARR(1,1),U,1))=$P(DIVARR(1,1),U,1,3)_U
|
|---|
| 81 | ;
|
|---|
| 82 | ; get last Division selected by the user (spacebar recall)
|
|---|
| 83 | S ACKDEF=$$FIND1^DIC(509850.83,",1,",""," ")
|
|---|
| 84 | S ACKDEF=$S(ACKDEF:$$EXTERNAL^DILFD(509850.83,".01","",ACKDEF),1:"")
|
|---|
| 85 | S ACKDEF=$$UC(ACKDEF) ; convert to uppercase
|
|---|
| 86 | I ACKDEF'="",'$D(DIVARR(2,ACKDEF)) S ACKDEF=""
|
|---|
| 87 | S ACKDFLT=$S(ACKDEF="":"",1:"2^"_ACKDEF)
|
|---|
| 88 | ;
|
|---|
| 89 | ; multiple divisions exist, only one required.
|
|---|
| 90 | I ACKTYP=1,DIVARR>1 D G DIVX
|
|---|
| 91 | . D SELECT^ACKQSEL(1,"DIVARR(2)","DIVARR(4)","DIVISION^35","D DIVHLP^ACKQUTL2",ACKDFLT)
|
|---|
| 92 | . ; get Division IEN
|
|---|
| 93 | . I $O(DIVARR(4,""))="" S ACKDIV="0^"_DIVARR Q ; either quit or timed out
|
|---|
| 94 | . S ACKDIVN=$O(DIVARR(4,"")),ACKN=DIVARR(2,ACKDIVN)
|
|---|
| 95 | . S ACKIEN=$P(DIVARR(1,ACKN),U,1)
|
|---|
| 96 | . D RECALL^DILFD(509850.83,ACKIEN_",1,",DUZ) ; save for spacebar recall
|
|---|
| 97 | . S ACKDIV="1^"_DIVARR
|
|---|
| 98 | . S ACKDIV(ACKIEN)=$P(DIVARR(1,ACKN),U,1,3)_U
|
|---|
| 99 | ;
|
|---|
| 100 | ; multiple divisions exist, user may select one/many or ALL.
|
|---|
| 101 | I ACKTYP>1,DIVARR>1 D G DIVX
|
|---|
| 102 | . D SELECT^ACKQSEL(ACKTYP,"DIVARR(2)","DIVARR(4)","DIVISION^35","D DIVHLP^ACKQUTL2",ACKDFLT)
|
|---|
| 103 | . ; get Division IEN
|
|---|
| 104 | . I $G(DIVARR(4))'="" S ACKDIV="0^"_DIVARR Q ;either quit or timed out
|
|---|
| 105 | . S ACKDIV=U_DIVARR
|
|---|
| 106 | . S ACKX="" F S ACKX=$O(DIVARR(4,ACKX)) Q:ACKX="" D
|
|---|
| 107 | . . S $P(ACKDIV,U,1)=$P(ACKDIV,U,1)+1,ACKN=DIVARR(2,ACKX)
|
|---|
| 108 | . . S ACKDIV($P(DIVARR(1,ACKN),U,1))=$P(DIVARR(1,ACKN),U,1,3)_U
|
|---|
| 109 | . ; if only one selected then save for spacebar recall
|
|---|
| 110 | . I +$P(ACKDIV,U,1)=1 D
|
|---|
| 111 | . . S ACKIEN=$O(ACKDIV("")) Q:'ACKIEN
|
|---|
| 112 | . . D RECALL^DILFD(509850.83,ACKIEN_",1,",DUZ) ; save for spacebar recall
|
|---|
| 113 | ;
|
|---|
| 114 | DIVX ; end
|
|---|
| 115 | Q ACKDIV
|
|---|
| 116 | ;
|
|---|
| 117 | ;
|
|---|
| 118 | DIVHLP ; displays help text for the Division prompt
|
|---|
| 119 | N X,DIWL,DIWR,DIWF
|
|---|
| 120 | S DIWL=1,DIWR=80,DIWF=""
|
|---|
| 121 | S X=" " D ^DIWP
|
|---|
| 122 | S X=" Enter the name of a Division from the A&SP Site Parameters File." D ^DIWP
|
|---|
| 123 | S X=" Enter '??' to see a list of the available Divisions, '^' to exit." D ^DIWP
|
|---|
| 124 | D ^DIWW
|
|---|
| 125 | Q
|
|---|
| 126 | LEADROLE(ACKVIEN) ; determine lead role for a visit
|
|---|
| 127 | ; prior to version 3.0 all visits would be filed with a Lead Role
|
|---|
| 128 | ; entered by the user (either the primary clinician, secondary
|
|---|
| 129 | ; clinician or other prov). With ver 3.0 this field is no longer
|
|---|
| 130 | ; populated and the lead role is the primary provider, or if absent
|
|---|
| 131 | ; the secondary provider. In order to be backward compatible this
|
|---|
| 132 | ; function will check the lead role field first. If it contains a
|
|---|
| 133 | ; value then the visit must be pre-ver 3.0 and this code must be
|
|---|
| 134 | ; the lead role selected by the user. If the lead role field is
|
|---|
| 135 | ; empty then the visit must be post-ver 3.0 and so this function
|
|---|
| 136 | ; will return either the primary or secondary provider.
|
|---|
| 137 | N ACKSECV2,ACKTGT,ACKMSG,ACKLEAD,ACKIENS,ACKPRIM,ACKSCND,ACKSTUD,ACKMSG1,ACKTGT1
|
|---|
| 138 | N ACK2
|
|---|
| 139 | S ACKIENS=ACKVIEN_","
|
|---|
| 140 | D GETS^DIQ(509850.6,ACKIENS,".25;.27;6","I","ACKTGT","ACKMSG")
|
|---|
| 141 | S ACKLEAD=ACKTGT(509850.6,ACKIENS,.27,"I") ; Lead role (Pre V.3.)
|
|---|
| 142 | I +ACKLEAD>0 Q +ACKLEAD
|
|---|
| 143 | S ACKPRIM=ACKTGT(509850.6,ACKIENS,6,"I") ; Primary clinician
|
|---|
| 144 | I +ACKPRIM>0 Q +ACKPRIM
|
|---|
| 145 | S ACKSECV2=ACKTGT(509850.6,ACKIENS,.25,"I") ; Pre V.3 Sec'dry clinician
|
|---|
| 146 | I +ACKSECV2>0 Q +ACKSECV2
|
|---|
| 147 | ;
|
|---|
| 148 | D LIST^DIC(509850.66,","_ACKVIEN_",",".01","I","*","","","","","","ACKTGT1","ACKMSG1")
|
|---|
| 149 | S ACKSCND=$O(ACKTGT1("DILIST",1,""))
|
|---|
| 150 | I ACKSCND'="" S ACKSCND=ACKTGT1("DILIST",1,ACKSCND)
|
|---|
| 151 | Q +ACKSCND ; First Secondary Provider V.3.
|
|---|
| 152 | ;
|
|---|
| 153 | ASPDIV(ACKDIV) ; returns true if ACKDIV is a valid ASP division
|
|---|
| 154 | N ACKTGT,ACKMSG,ACKFND
|
|---|
| 155 | ; look for the Division on the Site Parameters file
|
|---|
| 156 | D FIND^DIC(509850.83,",1,","","","`"_ACKDIV,1,"","","","ACKTGT","ACKMSG")
|
|---|
| 157 | ; get number found
|
|---|
| 158 | S ACKFND=$P($G(ACKTGT("DILIST",0)),U,1)
|
|---|
| 159 | Q (ACKFND=1)
|
|---|
| 160 | CLNDIV(ACKCLN) ; returns the ien of the division that the clinic is in.
|
|---|
| 161 | Q $$GET1^DIQ(44,ACKCLN_",",3.5,"I")
|
|---|
| 162 | ASPCLN(ACKCLN) ; returns true if ACKCLN is a valid clinic for ASP
|
|---|
| 163 | ; ACKCLN is the internal entry number from the hospital locations file
|
|---|
| 164 | ; true returned if stop code is 203-Audiology, 204-Speech
|
|---|
| 165 | ; if stop code is invalid then the credit stop code field must be either 203 or 204.
|
|---|
| 166 | N ACKSTOP,ACKCRDT,ACKSC
|
|---|
| 167 | ; get ien of stop code
|
|---|
| 168 | S ACKSTOP=$$GET1^DIQ(44,ACKCLN_",",8,"I")
|
|---|
| 169 | I ACKSTOP="" Q 0 ; bad clinic record
|
|---|
| 170 | ; get actual stop code
|
|---|
| 171 | S ACKSC=$$GET1^DIQ(40.7,ACKSTOP_",",1)
|
|---|
| 172 | ; exit
|
|---|
| 173 | I ACKSC=203 Q 1 ; audiology
|
|---|
| 174 | I ACKSC=204 Q 1 ; speech pathology
|
|---|
| 175 | ; get clinic credit stop code
|
|---|
| 176 | S ACKCRDT=$$GET1^DIQ(44,ACKCLN_",",2503,"I")
|
|---|
| 177 | I ACKCRDT="" Q 0 ; no credit stop code
|
|---|
| 178 | ; get actual stop code
|
|---|
| 179 | S ACKSC=$$GET1^DIQ(40.7,ACKCRDT_",",1)
|
|---|
| 180 | ; exit
|
|---|
| 181 | I ACKSC=203 Q 1 ; audiology
|
|---|
| 182 | I ACKSC=204 Q 1 ; speech pathology
|
|---|
| 183 | Q 0 ; any other value is invalid
|
|---|
| 184 | UC(X) ; convert X to uppercase
|
|---|
| 185 | Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
|
|---|
| 186 | ;
|
|---|
