Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ACKQUTL2

ACKQUTL2.m

Go to the documentation of this file.
  1. 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
  1. ;Per VHA Directive 10-93-142, this routine SHOULD NOT be modified.
  1. ;
  1. ;
  1. 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
  1. ; optional ACKTXT = preceding message
  1. N ACKFROM,ACKFDA,ACKMSG,ACKSCRN,DIWL,DIWR,DIWF,X,Y,I,DA,ACKCT
  1. S ACKFROM="",ACKTYP=$S(+$G(ACKTYP)=1:1,1:0)
  1. ; set up the screen if only active divisions are to be listed
  1. S ACKSCRN=$S(ACKTYP=1:"I $P(^(0),U,2)=""A""",1:"")
  1. ; call fileman to retrieve the Divisions
  1. D LIST^DIC(509850.83,",1,",".01;.02","","",.ACKFROM,"","",ACKSCRN,"","ACKFDA","ACKMSG")
  1. ; get count of number of Divisions
  1. S ACKCT=$P(ACKFDA("DILIST",0),U,1)
  1. ; determine the text header
  1. I ACKCT=0,ACKTYP=0 S ACKTXT=" No Divisions have been set up."
  1. I ACKCT=0,ACKTYP=1 S ACKTXT=" There are no Active Divisions on file."
  1. I $G(ACKTXT)="" D
  1. . I ACKCT>0 S ACKTXT=" The following Divisions have been set up..."
  1. ;
  1. ; the following section uses DIWP & DIWW to format and output the text
  1. S DIWL=5,DIWR=75,DIWF=""
  1. S X="|SETTAB(10,40)| " D ^DIWP
  1. S X=" " D ^DIWP ;blank line!
  1. S X=ACKTXT D ^DIWP
  1. ; now output each Division
  1. F ACK=1:1:ACKCT D
  1. . ; print division name
  1. . S X=" |TAB|"_$E(ACKFDA("DILIST",1,ACK),1,25)
  1. . ; if all divisions to be printed then also print the status
  1. . I ACKTYP=0 S X=X_"|TAB|"_$$MC(ACKFDA("DILIST","ID",ACK,.02))
  1. . D ^DIWP
  1. ; now write to the screen
  1. D ^DIWW
  1. ;
  1. ; end
  1. Q
  1. ;
  1. MC(X) ; convert X to mixed case (1st upper, remainder lower)
  1. N UP,LW S UP="ABCDEFGHIJKLMNOPQRSTUVWXYZ",LW="abcdefghijklmnopqrstuvwxyz"
  1. Q $TR($E(X),LW,UP)_$TR($E(X,2,999),UP,LW)
  1. ;
  1. ;
  1. DIV(ACKTYP,ACKDIV,ACKSTA) ; prompt user for an A&SP Division
  1. ; where ACKTYP can be 1=one div, 2=many, 3=many/all
  1. ; if ACTYPE>1 then ACKDIV must be passed in by reference
  1. ; and ACKSTA contains the required status of the Division
  1. ; so if ACKSTA="A" then only active divisions may be chosen
  1. ; if ACKSTA="I" then only inactive divisions may be chosen
  1. ; if ACKSTA="AI" or "IA" then either active or inactive may be
  1. ; chosen. If not passed then "A" is used as the default.
  1. ; ------------------------------------------------------------
  1. ; function returns:-
  1. ; ACKDIV=a^b where a=no. divisions selected, and b=total
  1. ; available divisions.
  1. ; (if the user quits or times out then a=0)
  1. ; ACKDIV(x)=x^y^z where
  1. ; x=div ien on Med Cen Div file #40.8,
  1. ; y=div ien on Site Parameters #509850.83
  1. ; and z=division name
  1. ; ------------------------------------------------------------
  1. N DIVARR,ACKDIVN,ACKN,ACKDEF,ACKDFLT,ACKIEN,ACKX
  1. K ACKDIV
  1. ; initialise selected Division
  1. S ACKDIV=""
  1. ;
  1. ; check parameter has been passed in
  1. I "1/2/3"'[+$G(ACKTYP) G DIVX
  1. ;
  1. ; get list of divisions
  1. D GETDIV^ACKQRU(.DIVARR,$G(ACKSTA),"U")
  1. ;
  1. ; no Divisions exist
  1. I DIVARR<1 S ACKDIV=0 G DIVX
  1. ;
  1. ; only one Division exists
  1. I DIVARR=1 D G DIVX
  1. . S ACKDIV="1^1",ACKDIV($P(DIVARR(1,1),U,1))=$P(DIVARR(1,1),U,1,3)_U
  1. ;
  1. ; get last Division selected by the user (spacebar recall)
  1. S ACKDEF=$$FIND1^DIC(509850.83,",1,",""," ")
  1. S ACKDEF=$S(ACKDEF:$$EXTERNAL^DILFD(509850.83,".01","",ACKDEF),1:"")
  1. S ACKDEF=$$UC(ACKDEF) ; convert to uppercase
  1. I ACKDEF'="",'$D(DIVARR(2,ACKDEF)) S ACKDEF=""
  1. S ACKDFLT=$S(ACKDEF="":"",1:"2^"_ACKDEF)
  1. ;
  1. ; multiple divisions exist, only one required.
  1. I ACKTYP=1,DIVARR>1 D G DIVX
  1. . D SELECT^ACKQSEL(1,"DIVARR(2)","DIVARR(4)","DIVISION^35","D DIVHLP^ACKQUTL2",ACKDFLT)
  1. . ; get Division IEN
  1. . I $O(DIVARR(4,""))="" S ACKDIV="0^"_DIVARR Q ; either quit or timed out
  1. . S ACKDIVN=$O(DIVARR(4,"")),ACKN=DIVARR(2,ACKDIVN)
  1. . S ACKIEN=$P(DIVARR(1,ACKN),U,1)
  1. . D RECALL^DILFD(509850.83,ACKIEN_",1,",DUZ) ; save for spacebar recall
  1. . S ACKDIV="1^"_DIVARR
  1. . S ACKDIV(ACKIEN)=$P(DIVARR(1,ACKN),U,1,3)_U
  1. ;
  1. ; multiple divisions exist, user may select one/many or ALL.
  1. I ACKTYP>1,DIVARR>1 D G DIVX
  1. . D SELECT^ACKQSEL(ACKTYP,"DIVARR(2)","DIVARR(4)","DIVISION^35","D DIVHLP^ACKQUTL2",ACKDFLT)
  1. . ; get Division IEN
  1. . I $G(DIVARR(4))'="" S ACKDIV="0^"_DIVARR Q ;either quit or timed out
  1. . S ACKDIV=U_DIVARR
  1. . S ACKX="" F S ACKX=$O(DIVARR(4,ACKX)) Q:ACKX="" D
  1. . . S $P(ACKDIV,U,1)=$P(ACKDIV,U,1)+1,ACKN=DIVARR(2,ACKX)
  1. . . S ACKDIV($P(DIVARR(1,ACKN),U,1))=$P(DIVARR(1,ACKN),U,1,3)_U
  1. . ; if only one selected then save for spacebar recall
  1. . I +$P(ACKDIV,U,1)=1 D
  1. . . S ACKIEN=$O(ACKDIV("")) Q:'ACKIEN
  1. . . D RECALL^DILFD(509850.83,ACKIEN_",1,",DUZ) ; save for spacebar recall
  1. ;
  1. DIVX ; end
  1. Q ACKDIV
  1. ;
  1. ;
  1. DIVHLP ; displays help text for the Division prompt
  1. N X,DIWL,DIWR,DIWF
  1. S DIWL=1,DIWR=80,DIWF=""
  1. S X=" " D ^DIWP
  1. S X=" Enter the name of a Division from the A&SP Site Parameters File." D ^DIWP
  1. S X=" Enter '??' to see a list of the available Divisions, '^' to exit." D ^DIWP
  1. D ^DIWW
  1. Q
  1. LEADROLE(ACKVIEN) ; determine lead role for a visit
  1. ; prior to version 3.0 all visits would be filed with a Lead Role
  1. ; entered by the user (either the primary clinician, secondary
  1. ; clinician or other prov). With ver 3.0 this field is no longer
  1. ; populated and the lead role is the primary provider, or if absent
  1. ; the secondary provider. In order to be backward compatible this
  1. ; function will check the lead role field first. If it contains a
  1. ; value then the visit must be pre-ver 3.0 and this code must be
  1. ; the lead role selected by the user. If the lead role field is
  1. ; empty then the visit must be post-ver 3.0 and so this function
  1. ; will return either the primary or secondary provider.
  1. N ACKSECV2,ACKTGT,ACKMSG,ACKLEAD,ACKIENS,ACKPRIM,ACKSCND,ACKSTUD,ACKMSG1,ACKTGT1
  1. N ACK2
  1. S ACKIENS=ACKVIEN_","
  1. D GETS^DIQ(509850.6,ACKIENS,".25;.27;6","I","ACKTGT","ACKMSG")
  1. S ACKLEAD=ACKTGT(509850.6,ACKIENS,.27,"I") ; Lead role (Pre V.3.)
  1. I +ACKLEAD>0 Q +ACKLEAD
  1. S ACKPRIM=ACKTGT(509850.6,ACKIENS,6,"I") ; Primary clinician
  1. I +ACKPRIM>0 Q +ACKPRIM
  1. S ACKSECV2=ACKTGT(509850.6,ACKIENS,.25,"I") ; Pre V.3 Sec'dry clinician
  1. I +ACKSECV2>0 Q +ACKSECV2
  1. ;
  1. D LIST^DIC(509850.66,","_ACKVIEN_",",".01","I","*","","","","","","ACKTGT1","ACKMSG1")
  1. S ACKSCND=$O(ACKTGT1("DILIST",1,""))
  1. I ACKSCND'="" S ACKSCND=ACKTGT1("DILIST",1,ACKSCND)
  1. Q +ACKSCND ; First Secondary Provider V.3.
  1. ;
  1. ASPDIV(ACKDIV) ; returns true if ACKDIV is a valid ASP division
  1. N ACKTGT,ACKMSG,ACKFND
  1. ; look for the Division on the Site Parameters file
  1. D FIND^DIC(509850.83,",1,","","","`"_ACKDIV,1,"","","","ACKTGT","ACKMSG")
  1. ; get number found
  1. S ACKFND=$P($G(ACKTGT("DILIST",0)),U,1)
  1. Q (ACKFND=1)
  1. CLNDIV(ACKCLN) ; returns the ien of the division that the clinic is in.
  1. Q $$GET1^DIQ(44,ACKCLN_",",3.5,"I")
  1. ASPCLN(ACKCLN) ; returns true if ACKCLN is a valid clinic for ASP
  1. ; ACKCLN is the internal entry number from the hospital locations file
  1. ; true returned if stop code is 203-Audiology, 204-Speech
  1. ; if stop code is invalid then the credit stop code field must be either 203 or 204.
  1. N ACKSTOP,ACKCRDT,ACKSC
  1. ; get ien of stop code
  1. S ACKSTOP=$$GET1^DIQ(44,ACKCLN_",",8,"I")
  1. I ACKSTOP="" Q 0 ; bad clinic record
  1. ; get actual stop code
  1. S ACKSC=$$GET1^DIQ(40.7,ACKSTOP_",",1)
  1. ; exit
  1. I ACKSC=203 Q 1 ; audiology
  1. I ACKSC=204 Q 1 ; speech pathology
  1. ; get clinic credit stop code
  1. S ACKCRDT=$$GET1^DIQ(44,ACKCLN_",",2503,"I")
  1. I ACKCRDT="" Q 0 ; no credit stop code
  1. ; get actual stop code
  1. S ACKSC=$$GET1^DIQ(40.7,ACKCRDT_",",1)
  1. ; exit
  1. I ACKSC=203 Q 1 ; audiology
  1. I ACKSC=204 Q 1 ; speech pathology
  1. Q 0 ; any other value is invalid
  1. UC(X) ; convert X to uppercase
  1. Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
  1. ;