ACKQUTL2 ;AUG/JLTP BIR/PTD HCIOFO/AG -QUASAR Utility Routine ; [ 04/25/96 10:03 ]
;;3.0;QUASAR;**15**;Feb 11, 2000;Build 2
;Per VHA Directive 10-93-142, this routine SHOULD NOT be modified.
;
;
DIVLIST(ACKTYP,ACKTXT) ; list on screen all the Divisions on the Site Parameter File
; optional ACKTYP = type of list 1=Active only, 0 (default) = all
; optional ACKTXT = preceding message
N ACKFROM,ACKFDA,ACKMSG,ACKSCRN,DIWL,DIWR,DIWF,X,Y,I,DA,ACKCT
S ACKFROM="",ACKTYP=$S(+$G(ACKTYP)=1:1,1:0)
; set up the screen if only active divisions are to be listed
S ACKSCRN=$S(ACKTYP=1:"I $P(^(0),U,2)=""A""",1:"")
; call fileman to retrieve the Divisions
D LIST^DIC(509850.83,",1,",".01;.02","","",.ACKFROM,"","",ACKSCRN,"","ACKFDA","ACKMSG")
; get count of number of Divisions
S ACKCT=$P(ACKFDA("DILIST",0),U,1)
; determine the text header
I ACKCT=0,ACKTYP=0 S ACKTXT=" No Divisions have been set up."
I ACKCT=0,ACKTYP=1 S ACKTXT=" There are no Active Divisions on file."
I $G(ACKTXT)="" D
. I ACKCT>0 S ACKTXT=" The following Divisions have been set up..."
;
; the following section uses DIWP & DIWW to format and output the text
S DIWL=5,DIWR=75,DIWF=""
S X="|SETTAB(10,40)| " D ^DIWP
S X=" " D ^DIWP ;blank line!
S X=ACKTXT D ^DIWP
; now output each Division
F ACK=1:1:ACKCT D
. ; print division name
. S X=" |TAB|"_$E(ACKFDA("DILIST",1,ACK),1,25)
. ; if all divisions to be printed then also print the status
. I ACKTYP=0 S X=X_"|TAB|"_$$MC(ACKFDA("DILIST","ID",ACK,.02))
. D ^DIWP
; now write to the screen
D ^DIWW
;
; end
Q
;
MC(X) ; convert X to mixed case (1st upper, remainder lower)
N UP,LW S UP="ABCDEFGHIJKLMNOPQRSTUVWXYZ",LW="abcdefghijklmnopqrstuvwxyz"
Q $TR($E(X),LW,UP)_$TR($E(X,2,999),UP,LW)
;
;
DIV(ACKTYP,ACKDIV,ACKSTA) ; prompt user for an A&SP Division
; where ACKTYP can be 1=one div, 2=many, 3=many/all
; if ACTYPE>1 then ACKDIV must be passed in by reference
; and ACKSTA contains the required status of the Division
; so if ACKSTA="A" then only active divisions may be chosen
; if ACKSTA="I" then only inactive divisions may be chosen
; if ACKSTA="AI" or "IA" then either active or inactive may be
; chosen. If not passed then "A" is used as the default.
; ------------------------------------------------------------
; function returns:-
; ACKDIV=a^b where a=no. divisions selected, and b=total
; available divisions.
; (if the user quits or times out then a=0)
; ACKDIV(x)=x^y^z where
; x=div ien on Med Cen Div file #40.8,
; y=div ien on Site Parameters #509850.83
; and z=division name
; ------------------------------------------------------------
N DIVARR,ACKDIVN,ACKN,ACKDEF,ACKDFLT,ACKIEN,ACKX
K ACKDIV
; initialise selected Division
S ACKDIV=""
;
; check parameter has been passed in
I "1/2/3"'[+$G(ACKTYP) G DIVX
;
; get list of divisions
D GETDIV^ACKQRU(.DIVARR,$G(ACKSTA),"U")
;
; no Divisions exist
I DIVARR<1 S ACKDIV=0 G DIVX
;
; only one Division exists
I DIVARR=1 D G DIVX
. S ACKDIV="1^1",ACKDIV($P(DIVARR(1,1),U,1))=$P(DIVARR(1,1),U,1,3)_U
;
; get last Division selected by the user (spacebar recall)
S ACKDEF=$$FIND1^DIC(509850.83,",1,",""," ")
S ACKDEF=$S(ACKDEF:$$EXTERNAL^DILFD(509850.83,".01","",ACKDEF),1:"")
S ACKDEF=$$UC(ACKDEF) ; convert to uppercase
I ACKDEF'="",'$D(DIVARR(2,ACKDEF)) S ACKDEF=""
S ACKDFLT=$S(ACKDEF="":"",1:"2^"_ACKDEF)
;
; multiple divisions exist, only one required.
I ACKTYP=1,DIVARR>1 D G DIVX
. D SELECT^ACKQSEL(1,"DIVARR(2)","DIVARR(4)","DIVISION^35","D DIVHLP^ACKQUTL2",ACKDFLT)
. ; get Division IEN
. I $O(DIVARR(4,""))="" S ACKDIV="0^"_DIVARR Q ; either quit or timed out
. S ACKDIVN=$O(DIVARR(4,"")),ACKN=DIVARR(2,ACKDIVN)
. S ACKIEN=$P(DIVARR(1,ACKN),U,1)
. D RECALL^DILFD(509850.83,ACKIEN_",1,",DUZ) ; save for spacebar recall
. S ACKDIV="1^"_DIVARR
. S ACKDIV(ACKIEN)=$P(DIVARR(1,ACKN),U,1,3)_U
;
; multiple divisions exist, user may select one/many or ALL.
I ACKTYP>1,DIVARR>1 D G DIVX
. D SELECT^ACKQSEL(ACKTYP,"DIVARR(2)","DIVARR(4)","DIVISION^35","D DIVHLP^ACKQUTL2",ACKDFLT)
. ; get Division IEN
. I $G(DIVARR(4))'="" S ACKDIV="0^"_DIVARR Q ;either quit or timed out
. S ACKDIV=U_DIVARR
. S ACKX="" F S ACKX=$O(DIVARR(4,ACKX)) Q:ACKX="" D
. . S $P(ACKDIV,U,1)=$P(ACKDIV,U,1)+1,ACKN=DIVARR(2,ACKX)
. . S ACKDIV($P(DIVARR(1,ACKN),U,1))=$P(DIVARR(1,ACKN),U,1,3)_U
. ; if only one selected then save for spacebar recall
. I +$P(ACKDIV,U,1)=1 D
. . S ACKIEN=$O(ACKDIV("")) Q:'ACKIEN
. . D RECALL^DILFD(509850.83,ACKIEN_",1,",DUZ) ; save for spacebar recall
;
DIVX ; end
Q ACKDIV
;
;
DIVHLP ; displays help text for the Division prompt
N X,DIWL,DIWR,DIWF
S DIWL=1,DIWR=80,DIWF=""
S X=" " D ^DIWP
S X=" Enter the name of a Division from the A&SP Site Parameters File." D ^DIWP
S X=" Enter '??' to see a list of the available Divisions, '^' to exit." D ^DIWP
D ^DIWW
Q
LEADROLE(ACKVIEN) ; determine lead role for a visit
; prior to version 3.0 all visits would be filed with a Lead Role
; entered by the user (either the primary clinician, secondary
; clinician or other prov). With ver 3.0 this field is no longer
; populated and the lead role is the primary provider, or if absent
; the secondary provider. In order to be backward compatible this
; function will check the lead role field first. If it contains a
; value then the visit must be pre-ver 3.0 and this code must be
; the lead role selected by the user. If the lead role field is
; empty then the visit must be post-ver 3.0 and so this function
; will return either the primary or secondary provider.
N ACKSECV2,ACKTGT,ACKMSG,ACKLEAD,ACKIENS,ACKPRIM,ACKSCND,ACKSTUD,ACKMSG1,ACKTGT1
N ACK2
S ACKIENS=ACKVIEN_","
D GETS^DIQ(509850.6,ACKIENS,".25;.27;6","I","ACKTGT","ACKMSG")
S ACKLEAD=ACKTGT(509850.6,ACKIENS,.27,"I") ; Lead role (Pre V.3.)
I +ACKLEAD>0 Q +ACKLEAD
S ACKPRIM=ACKTGT(509850.6,ACKIENS,6,"I") ; Primary clinician
I +ACKPRIM>0 Q +ACKPRIM
S ACKSECV2=ACKTGT(509850.6,ACKIENS,.25,"I") ; Pre V.3 Sec'dry clinician
I +ACKSECV2>0 Q +ACKSECV2
;
D LIST^DIC(509850.66,","_ACKVIEN_",",".01","I","*","","","","","","ACKTGT1","ACKMSG1")
S ACKSCND=$O(ACKTGT1("DILIST",1,""))
I ACKSCND'="" S ACKSCND=ACKTGT1("DILIST",1,ACKSCND)
Q +ACKSCND ; First Secondary Provider V.3.
;
ASPDIV(ACKDIV) ; returns true if ACKDIV is a valid ASP division
N ACKTGT,ACKMSG,ACKFND
; look for the Division on the Site Parameters file
D FIND^DIC(509850.83,",1,","","","`"_ACKDIV,1,"","","","ACKTGT","ACKMSG")
; get number found
S ACKFND=$P($G(ACKTGT("DILIST",0)),U,1)
Q (ACKFND=1)
CLNDIV(ACKCLN) ; returns the ien of the division that the clinic is in.
Q $$GET1^DIQ(44,ACKCLN_",",3.5,"I")
ASPCLN(ACKCLN) ; returns true if ACKCLN is a valid clinic for ASP
; ACKCLN is the internal entry number from the hospital locations file
; true returned if stop code is 203-Audiology, 204-Speech
; if stop code is invalid then the credit stop code field must be either 203 or 204.
N ACKSTOP,ACKCRDT,ACKSC
; get ien of stop code
S ACKSTOP=$$GET1^DIQ(44,ACKCLN_",",8,"I")
I ACKSTOP="" Q 0 ; bad clinic record
; get actual stop code
S ACKSC=$$GET1^DIQ(40.7,ACKSTOP_",",1)
; exit
I ACKSC=203 Q 1 ; audiology
I ACKSC=204 Q 1 ; speech pathology
; get clinic credit stop code
S ACKCRDT=$$GET1^DIQ(44,ACKCLN_",",2503,"I")
I ACKCRDT="" Q 0 ; no credit stop code
; get actual stop code
S ACKSC=$$GET1^DIQ(40.7,ACKCRDT_",",1)
; exit
I ACKSC=203 Q 1 ; audiology
I ACKSC=204 Q 1 ; speech pathology
Q 0 ; any other value is invalid
UC(X) ; convert X to uppercase
Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HACKQUTL2 7904 printed Apr 09, 2024@21:34:46 Page 2
ACKQUTL2 ;AUG/JLTP BIR/PTD HCIOFO/AG -QUASAR Utility Routine ; [ 04/25/96 10:03 ]
+1 ;;3.0;QUASAR;**15**;Feb 11, 2000;Build 2
+2 ;Per VHA Directive 10-93-142, this routine SHOULD NOT be modified.
+3 ;
+4 ;
DIVLIST(ACKTYP,ACKTXT) ; list on screen all the Divisions on the Site Parameter File
+1 ; optional ACKTYP = type of list 1=Active only, 0 (default) = all
+2 ; optional ACKTXT = preceding message
+3 NEW ACKFROM,ACKFDA,ACKMSG,ACKSCRN,DIWL,DIWR,DIWF,X,Y,I,DA,ACKCT
+4 SET ACKFROM=""
SET ACKTYP=$SELECT(+$GET(ACKTYP)=1:1,1:0)
+5 ; set up the screen if only active divisions are to be listed
+6 SET ACKSCRN=$SELECT(ACKTYP=1:"I $P(^(0),U,2)=""A""",1:"")
+7 ; call fileman to retrieve the Divisions
+8 DO LIST^DIC(509850.83,",1,",".01;.02","","",.ACKFROM,"","",ACKSCRN,"","ACKFDA","ACKMSG")
+9 ; get count of number of Divisions
+10 SET ACKCT=$PIECE(ACKFDA("DILIST",0),U,1)
+11 ; determine the text header
+12 IF ACKCT=0
IF ACKTYP=0
SET ACKTXT=" No Divisions have been set up."
+13 IF ACKCT=0
IF ACKTYP=1
SET ACKTXT=" There are no Active Divisions on file."
+14 IF $GET(ACKTXT)=""
Begin DoDot:1
+15 IF ACKCT>0
SET ACKTXT=" The following Divisions have been set up..."
End DoDot:1
+16 ;
+17 ; the following section uses DIWP & DIWW to format and output the text
+18 SET DIWL=5
SET DIWR=75
SET DIWF=""
+19 SET X="|SETTAB(10,40)| "
DO ^DIWP
+20 ;blank line!
SET X=" "
DO ^DIWP
+21 SET X=ACKTXT
DO ^DIWP
+22 ; now output each Division
+23 FOR ACK=1:1:ACKCT
Begin DoDot:1
+24 ; print division name
+25 SET X=" |TAB|"_$EXTRACT(ACKFDA("DILIST",1,ACK),1,25)
+26 ; if all divisions to be printed then also print the status
+27 IF ACKTYP=0
SET X=X_"|TAB|"_$$MC(ACKFDA("DILIST","ID",ACK,.02))
+28 DO ^DIWP
End DoDot:1
+29 ; now write to the screen
+30 DO ^DIWW
+31 ;
+32 ; end
+33 QUIT
+34 ;
MC(X) ; convert X to mixed case (1st upper, remainder lower)
+1 NEW UP,LW
SET UP="ABCDEFGHIJKLMNOPQRSTUVWXYZ"
SET LW="abcdefghijklmnopqrstuvwxyz"
+2 QUIT $TRANSLATE($EXTRACT(X),LW,UP)_$TRANSLATE($EXTRACT(X,2,999),UP,LW)
+3 ;
+4 ;
DIV(ACKTYP,ACKDIV,ACKSTA) ; prompt user for an A&SP Division
+1 ; where ACKTYP can be 1=one div, 2=many, 3=many/all
+2 ; if ACTYPE>1 then ACKDIV must be passed in by reference
+3 ; and ACKSTA contains the required status of the Division
+4 ; so if ACKSTA="A" then only active divisions may be chosen
+5 ; if ACKSTA="I" then only inactive divisions may be chosen
+6 ; if ACKSTA="AI" or "IA" then either active or inactive may be
+7 ; chosen. If not passed then "A" is used as the default.
+8 ; ------------------------------------------------------------
+9 ; function returns:-
+10 ; ACKDIV=a^b where a=no. divisions selected, and b=total
+11 ; available divisions.
+12 ; (if the user quits or times out then a=0)
+13 ; ACKDIV(x)=x^y^z where
+14 ; x=div ien on Med Cen Div file #40.8,
+15 ; y=div ien on Site Parameters #509850.83
+16 ; and z=division name
+17 ; ------------------------------------------------------------
+18 NEW DIVARR,ACKDIVN,ACKN,ACKDEF,ACKDFLT,ACKIEN,ACKX
+19 KILL ACKDIV
+20 ; initialise selected Division
+21 SET ACKDIV=""
+22 ;
+23 ; check parameter has been passed in
+24 IF "1/2/3"'[+$GET(ACKTYP)
GOTO DIVX
+25 ;
+26 ; get list of divisions
+27 DO GETDIV^ACKQRU(.DIVARR,$GET(ACKSTA),"U")
+28 ;
+29 ; no Divisions exist
+30 IF DIVARR<1
SET ACKDIV=0
GOTO DIVX
+31 ;
+32 ; only one Division exists
+33 IF DIVARR=1
Begin DoDot:1
+34 SET ACKDIV="1^1"
SET ACKDIV($PIECE(DIVARR(1,1),U,1))=$PIECE(DIVARR(1,1),U,1,3)_U
End DoDot:1
GOTO DIVX
+35 ;
+36 ; get last Division selected by the user (spacebar recall)
+37 SET ACKDEF=$$FIND1^DIC(509850.83,",1,",""," ")
+38 SET ACKDEF=$SELECT(ACKDEF:$$EXTERNAL^DILFD(509850.83,".01","",ACKDEF),1:"")
+39 ; convert to uppercase
SET ACKDEF=$$UC(ACKDEF)
+40 IF ACKDEF'=""
IF '$DATA(DIVARR(2,ACKDEF))
SET ACKDEF=""
+41 SET ACKDFLT=$SELECT(ACKDEF="":"",1:"2^"_ACKDEF)
+42 ;
+43 ; multiple divisions exist, only one required.
+44 IF ACKTYP=1
IF DIVARR>1
Begin DoDot:1
+45 DO SELECT^ACKQSEL(1,"DIVARR(2)","DIVARR(4)","DIVISION^35","D DIVHLP^ACKQUTL2",ACKDFLT)
+46 ; get Division IEN
+47 ; either quit or timed out
IF $ORDER(DIVARR(4,""))=""
SET ACKDIV="0^"_DIVARR
QUIT
+48 SET ACKDIVN=$ORDER(DIVARR(4,""))
SET ACKN=DIVARR(2,ACKDIVN)
+49 SET ACKIEN=$PIECE(DIVARR(1,ACKN),U,1)
+50 ; save for spacebar recall
DO RECALL^DILFD(509850.83,ACKIEN_",1,",DUZ)
+51 SET ACKDIV="1^"_DIVARR
+52 SET ACKDIV(ACKIEN)=$PIECE(DIVARR(1,ACKN),U,1,3)_U
End DoDot:1
GOTO DIVX
+53 ;
+54 ; multiple divisions exist, user may select one/many or ALL.
+55 IF ACKTYP>1
IF DIVARR>1
Begin DoDot:1
+56 DO SELECT^ACKQSEL(ACKTYP,"DIVARR(2)","DIVARR(4)","DIVISION^35","D DIVHLP^ACKQUTL2",ACKDFLT)
+57 ; get Division IEN
+58 ;either quit or timed out
IF $GET(DIVARR(4))'=""
SET ACKDIV="0^"_DIVARR
QUIT
+59 SET ACKDIV=U_DIVARR
+60 SET ACKX=""
FOR
SET ACKX=$ORDER(DIVARR(4,ACKX))
if ACKX=""
QUIT
Begin DoDot:2
+61 SET $PIECE(ACKDIV,U,1)=$PIECE(ACKDIV,U,1)+1
SET ACKN=DIVARR(2,ACKX)
+62 SET ACKDIV($PIECE(DIVARR(1,ACKN),U,1))=$PIECE(DIVARR(1,ACKN),U,1,3)_U
End DoDot:2
+63 ; if only one selected then save for spacebar recall
+64 IF +$PIECE(ACKDIV,U,1)=1
Begin DoDot:2
+65 SET ACKIEN=$ORDER(ACKDIV(""))
if 'ACKIEN
QUIT
+66 ; save for spacebar recall
DO RECALL^DILFD(509850.83,ACKIEN_",1,",DUZ)
End DoDot:2
End DoDot:1
GOTO DIVX
+67 ;
DIVX ; end
+1 QUIT ACKDIV
+2 ;
+3 ;
DIVHLP ; displays help text for the Division prompt
+1 NEW X,DIWL,DIWR,DIWF
+2 SET DIWL=1
SET DIWR=80
SET DIWF=""
+3 SET X=" "
DO ^DIWP
+4 SET X=" Enter the name of a Division from the A&SP Site Parameters File."
DO ^DIWP
+5 SET X=" Enter '??' to see a list of the available Divisions, '^' to exit."
DO ^DIWP
+6 DO ^DIWW
+7 QUIT
LEADROLE(ACKVIEN) ; determine lead role for a visit
+1 ; prior to version 3.0 all visits would be filed with a Lead Role
+2 ; entered by the user (either the primary clinician, secondary
+3 ; clinician or other prov). With ver 3.0 this field is no longer
+4 ; populated and the lead role is the primary provider, or if absent
+5 ; the secondary provider. In order to be backward compatible this
+6 ; function will check the lead role field first. If it contains a
+7 ; value then the visit must be pre-ver 3.0 and this code must be
+8 ; the lead role selected by the user. If the lead role field is
+9 ; empty then the visit must be post-ver 3.0 and so this function
+10 ; will return either the primary or secondary provider.
+11 NEW ACKSECV2,ACKTGT,ACKMSG,ACKLEAD,ACKIENS,ACKPRIM,ACKSCND,ACKSTUD,ACKMSG1,ACKTGT1
+12 NEW ACK2
+13 SET ACKIENS=ACKVIEN_","
+14 DO GETS^DIQ(509850.6,ACKIENS,".25;.27;6","I","ACKTGT","ACKMSG")
+15 ; Lead role (Pre V.3.)
SET ACKLEAD=ACKTGT(509850.6,ACKIENS,.27,"I")
+16 IF +ACKLEAD>0
QUIT +ACKLEAD
+17 ; Primary clinician
SET ACKPRIM=ACKTGT(509850.6,ACKIENS,6,"I")
+18 IF +ACKPRIM>0
QUIT +ACKPRIM
+19 ; Pre V.3 Sec'dry clinician
SET ACKSECV2=ACKTGT(509850.6,ACKIENS,.25,"I")
+20 IF +ACKSECV2>0
QUIT +ACKSECV2
+21 ;
+22 DO LIST^DIC(509850.66,","_ACKVIEN_",",".01","I","*","","","","","","ACKTGT1","ACKMSG1")
+23 SET ACKSCND=$ORDER(ACKTGT1("DILIST",1,""))
+24 IF ACKSCND'=""
SET ACKSCND=ACKTGT1("DILIST",1,ACKSCND)
+25 ; First Secondary Provider V.3.
QUIT +ACKSCND
+26 ;
ASPDIV(ACKDIV) ; returns true if ACKDIV is a valid ASP division
+1 NEW ACKTGT,ACKMSG,ACKFND
+2 ; look for the Division on the Site Parameters file
+3 DO FIND^DIC(509850.83,",1,","","","`"_ACKDIV,1,"","","","ACKTGT","ACKMSG")
+4 ; get number found
+5 SET ACKFND=$PIECE($GET(ACKTGT("DILIST",0)),U,1)
+6 QUIT (ACKFND=1)
CLNDIV(ACKCLN) ; returns the ien of the division that the clinic is in.
+1 QUIT $$GET1^DIQ(44,ACKCLN_",",3.5,"I")
ASPCLN(ACKCLN) ; returns true if ACKCLN is a valid clinic for ASP
+1 ; ACKCLN is the internal entry number from the hospital locations file
+2 ; true returned if stop code is 203-Audiology, 204-Speech
+3 ; if stop code is invalid then the credit stop code field must be either 203 or 204.
+4 NEW ACKSTOP,ACKCRDT,ACKSC
+5 ; get ien of stop code
+6 SET ACKSTOP=$$GET1^DIQ(44,ACKCLN_",",8,"I")
+7 ; bad clinic record
IF ACKSTOP=""
QUIT 0
+8 ; get actual stop code
+9 SET ACKSC=$$GET1^DIQ(40.7,ACKSTOP_",",1)
+10 ; exit
+11 ; audiology
IF ACKSC=203
QUIT 1
+12 ; speech pathology
IF ACKSC=204
QUIT 1
+13 ; get clinic credit stop code
+14 SET ACKCRDT=$$GET1^DIQ(44,ACKCLN_",",2503,"I")
+15 ; no credit stop code
IF ACKCRDT=""
QUIT 0
+16 ; get actual stop code
+17 SET ACKSC=$$GET1^DIQ(40.7,ACKCRDT_",",1)
+18 ; exit
+19 ; audiology
IF ACKSC=203
QUIT 1
+20 ; speech pathology
IF ACKSC=204
QUIT 1
+21 ; any other value is invalid
QUIT 0
UC(X) ; convert X to uppercase
+1 QUIT $TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+2 ;
