ACKQRU ;AUG/JLTP BIR/PTD HCIOFO/AG-Support Routine for Reports ; 9/2/09 11:56am
;;3.0;QUASAR;**17**;Feb 11, 2000;Build 28
;Per VHA Directive 10-93-142, this routine SHOULD NOT be modified.
DTRANGE ;
BEGDT N ACKTMPB
S DIR(0)="D^:"_DT_":AEXP",DIR("A")="Beginning Date"
S DIR("?")="Enter the earliest date for which you want to see data"
S DIR("??")="^S ACKQHLP=1 D ^ACKQHLP"
D ^DIR K DIR
I Y?1"^"1.E W !,"Jumping not allowed.",! G BEGDT
Q:$D(DIRUT) S ACKBD=Y-.1,ACKXBD=$$NUMDT^ACKQUTL(Y),ACKTMPB=Y
;
ENDDT ; S DIR(0)="D^"_(ACKBD+.1)_":"_DT_":AEXP",DIR("A")="Ending Date"
S DIR(0)="D"
S DIR("A")="Ending Date"
S DIR("?")="Enter the latest date for which you want to see data"
S DIR("??")="^S ACKQHLP=1 D ^ACKQHLP"
D ^DIR K DIR
I Y?1"^"1.E W !,"Jumping not allowed.",! G ENDDT
Q:$D(DIRUT) S ACKED=Y+.9,ACKXED=$$NUMDT^ACKQUTL(Y)
I Y<ACKTMPB W !,"End date cannot be before the Begin date.",! G ENDDT
Q
PARAMS ;
; this subroutine contains two standard prompts
; 1. Select a = AUDIOLOGY
; s = SPEECH PATHOLOGY
; b = BOTH
; 2. Choose 1 = ONE CLINICIAN
; 2 = ONE OTHER PROVIDER
; 3 = ONE STUDENT
; 4 = ALL CLINICIANS
; 5 = ALL OTHER PROVIDERS
; 6 = ALL STUDENTS
; it returns
; DIRUT=1 user chose to exit
; ACKASB response to prompt 1
; (A=audio, S=speech, B=Both)
; ACKSS response to prompt 2 (1-6)
; ACKSTF() array containing all selected staff
; where ACKSTF(n)=persons IEN on NEW PERSON FILE
;
N DIR,I,X,Y,DIC,ACKQHLP
;
; prompt 1
S DIR(0)="S^a:AUDIOLOGY;s:SPEECH PATHOLOGY;b:BOTH"
S DIR("A")="Select",DIR("B")="BOTH"
S DIR("??")="^W !!,""You can select Audiology visits, Speech Pathology visits, or Both."",!"
D ^DIR K DIR Q:$D(DIRUT)
S ACKASB=$S(Y="a":"A",Y="s":"S",1:"B")
;
; prompt 2
S DIR(0)="S^1:ONE CLINICIAN;2:ONE OTHER PROVIDER;3:ONE STUDENT;4:ALL CLINICIANS;5:ALL OTHER PROVIDERS;6:ALL STUDENTS"
S DIR("A")="Choose",DIR("??")="^S ACKQHLP=4 D ^ACKQHLP"
D ^DIR K DIR Q:$D(DIRUT)
S ACKSS=Y
K ACKSTF
; if ONE staff member selected then ask for name
I ACKSS<4 D Q:$D(DIRUT)
. S DIC("A")="Select "_$S(ACKSS=1:"CLINICIAN",ACKSS=2:"OTHER PROVIDER",1:"STUDENT")_": "
. S DIC(0)="AEMQZ",DIC=509850.3
. S DIC("S")="I $P(^(0),U,2)]"""",$P(""CF^O^S"",U,ACKSS)[$P(^(0),U,2)"
. D ^DIC K DIC S:Y<0 DIRUT=1 Q:$D(DIRUT)
. ;*17 Update to correctly set DUZ
. ;S ACKSTF(+Y)=$P(Y,U,2)
. S ACKSTF(+Y)=$$CONVERT1^ACKQUTL4(+Y)
; if ALL staff selected then get them from staff file
I ACKSS>3 D
. S I=0 F S I=$O(^ACK(509850.3,I)) Q:'I D
. . S X=$P(^ACK(509850.3,I,0),U,2)
. . I X="" Q
. . I ACKSS=4,"CF"'[X Q
. . I ACKSS=5,X'="O" Q
. . I ACKSS=6,X'="S" Q
. . ;*17 Update to correctly set DUZ
. . ;S ACKSTF(I)=$P(^ACK(509850.3,I,0),U)
. . S ACKSTF(I)=$$CONVERT1^ACKQUTL4(I)
;
; end
Q
;
GETDIV(DIVARR,ACKSTA,ACKOPT) ; get all the Divisions and put them in DIVARR
; INPUT: DIVARR must be passed by reference
; ACKSTA division status (optional)
; 'A' will get active divisions only (default)
; 'I' will get inactive divisions only
; 'AI' or 'IA' will get all divisions
; ACKOPT options. so far the only option is 'U' to output the
; names in uppercase.
; RETURNS: DIVARR= number found (n)
; DIVARR(1,n)=x^y^name
; DIVARR(2,name)=n
; and DIVARR(3,x)=n
; where x=IEN of Div from Medical Center Division file
; and y=sequence number from A&SP Site Parameter file
; (in other words ^ACK(509850.8,1,2,y)=x^...)
; and name=the division name
;
N ACKTGT,ACKMSG,ACKSCRN,ACK,SEQ,DIV,DIVNAME
K DIVARR
; build screen based on requested status
I $G(ACKSTA)="" S ACKSTA="A"
S ACKSCRN="I """_ACKSTA_"""[$P(^(0),U,2)"
; go get 'em
D LIST^DIC(509850.83,",1,",".01","I","*","","","",ACKSCRN,"","ACKTGT","ACKMSG")
; now transfer to output array
S DIVARR=$P(ACKTGT("DILIST",0),U,1)
FOR ACK=1:1:DIVARR D
. S SEQ=ACKTGT("DILIST",2,ACK),DIV=ACKTGT("DILIST",1,ACK)
. S DIVNAME=$$GET1^DIQ(40.8,DIV_",",.01)
. S DIVARR(1,ACK)=DIV_U_SEQ_U_DIVNAME
. S DIVARR(2,$$UP($G(ACKOPT),DIVNAME))=ACK
. S DIVARR(3,DIV)=ACK
Q
UP(ACKOPT,X) ; convert X to uppercase (if requested)
I ACKOPT["U" Q $TR(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
Q X
;
STOPSORT(ACKASB,ACKVSC) ; determine stop code sort value
; this function determines whether the Stop Code for the Visit is
; valid for the type of report selected.
; If it is not valid the function returns 0
; If it is valid the function returns an integer which may be used to
; sequence the visit so that Audio comes first, Audio/Tel next,
; then Speech and Speech/Tel.
; If an unknown Visit Stop Code is encountered, it is given a 9
; which means it will appear at the end of the report as UNKNOWN.
I ACKVSC="A" Q $S(ACKASB="A":1,ACKASB="B":1,1:0) ; audiology #1
I ACKVSC="AT" Q $S(ACKASB="A":2,ACKASB="B":2,1:0) ; telephone audiology #2
I ACKVSC="S" Q $S(ACKASB="S":3,ACKASB="B":3,1:0) ; speech #3
I ACKVSC="ST" Q $S(ACKASB="S":4,ACKASB="B":4,1:0) ; telephone speech #4
Q 9 ; any other value 9
;
STOPNM(ACKSORT) ; convert stop code sort value into a stop code name
I ACKSORT=1 Q "AUDIOLOGY"
I ACKSORT=2 Q "AUDIOLOGY TELEPHONE"
I ACKSORT=3 Q "SPEECH PATHOLOGY"
I ACKSORT=4 Q "SPEECH TELEPHONE"
Q "UNKNOWN"
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HACKQRU 5669 printed Apr 09, 2024@21:35:05 Page 2
ACKQRU ;AUG/JLTP BIR/PTD HCIOFO/AG-Support Routine for Reports ; 9/2/09 11:56am
+1 ;;3.0;QUASAR;**17**;Feb 11, 2000;Build 28
+2 ;Per VHA Directive 10-93-142, this routine SHOULD NOT be modified.
DTRANGE ;
BEGDT NEW ACKTMPB
+1 SET DIR(0)="D^:"_DT_":AEXP"
SET DIR("A")="Beginning Date"
+2 SET DIR("?")="Enter the earliest date for which you want to see data"
+3 SET DIR("??")="^S ACKQHLP=1 D ^ACKQHLP"
+4 DO ^DIR
KILL DIR
+5 IF Y?1"^"1.E
WRITE !,"Jumping not allowed.",!
GOTO BEGDT
+6 if $DATA(DIRUT)
QUIT
SET ACKBD=Y-.1
SET ACKXBD=$$NUMDT^ACKQUTL(Y)
SET ACKTMPB=Y
+7 ;
ENDDT ; S DIR(0)="D^"_(ACKBD+.1)_":"_DT_":AEXP",DIR("A")="Ending Date"
+1 SET DIR(0)="D"
+2 SET DIR("A")="Ending Date"
+3 SET DIR("?")="Enter the latest date for which you want to see data"
+4 SET DIR("??")="^S ACKQHLP=1 D ^ACKQHLP"
+5 DO ^DIR
KILL DIR
+6 IF Y?1"^"1.E
WRITE !,"Jumping not allowed.",!
GOTO ENDDT
+7 if $DATA(DIRUT)
QUIT
SET ACKED=Y+.9
SET ACKXED=$$NUMDT^ACKQUTL(Y)
+8 IF Y<ACKTMPB
WRITE !,"End date cannot be before the Begin date.",!
GOTO ENDDT
+9 QUIT
PARAMS ;
+1 ; this subroutine contains two standard prompts
+2 ; 1. Select a = AUDIOLOGY
+3 ; s = SPEECH PATHOLOGY
+4 ; b = BOTH
+5 ; 2. Choose 1 = ONE CLINICIAN
+6 ; 2 = ONE OTHER PROVIDER
+7 ; 3 = ONE STUDENT
+8 ; 4 = ALL CLINICIANS
+9 ; 5 = ALL OTHER PROVIDERS
+10 ; 6 = ALL STUDENTS
+11 ; it returns
+12 ; DIRUT=1 user chose to exit
+13 ; ACKASB response to prompt 1
+14 ; (A=audio, S=speech, B=Both)
+15 ; ACKSS response to prompt 2 (1-6)
+16 ; ACKSTF() array containing all selected staff
+17 ; where ACKSTF(n)=persons IEN on NEW PERSON FILE
+18 ;
+19 NEW DIR,I,X,Y,DIC,ACKQHLP
+20 ;
+21 ; prompt 1
+22 SET DIR(0)="S^a:AUDIOLOGY;s:SPEECH PATHOLOGY;b:BOTH"
+23 SET DIR("A")="Select"
SET DIR("B")="BOTH"
+24 SET DIR("??")="^W !!,""You can select Audiology visits, Speech Pathology visits, or Both."",!"
+25 DO ^DIR
KILL DIR
if $DATA(DIRUT)
QUIT
+26 SET ACKASB=$SELECT(Y="a":"A",Y="s":"S",1:"B")
+27 ;
+28 ; prompt 2
+29 SET DIR(0)="S^1:ONE CLINICIAN;2:ONE OTHER PROVIDER;3:ONE STUDENT;4:ALL CLINICIANS;5:ALL OTHER PROVIDERS;6:ALL STUDENTS"
+30 SET DIR("A")="Choose"
SET DIR("??")="^S ACKQHLP=4 D ^ACKQHLP"
+31 DO ^DIR
KILL DIR
if $DATA(DIRUT)
QUIT
+32 SET ACKSS=Y
+33 KILL ACKSTF
+34 ; if ONE staff member selected then ask for name
+35 IF ACKSS<4
Begin DoDot:1
+36 SET DIC("A")="Select "_$SELECT(ACKSS=1:"CLINICIAN",ACKSS=2:"OTHER PROVIDER",1:"STUDENT")_": "
+37 SET DIC(0)="AEMQZ"
SET DIC=509850.3
+38 SET DIC("S")="I $P(^(0),U,2)]"""",$P(""CF^O^S"",U,ACKSS)[$P(^(0),U,2)"
+39 DO ^DIC
KILL DIC
if Y<0
SET DIRUT=1
if $DATA(DIRUT)
QUIT
+40 ;*17 Update to correctly set DUZ
+41 ;S ACKSTF(+Y)=$P(Y,U,2)
+42 SET ACKSTF(+Y)=$$CONVERT1^ACKQUTL4(+Y)
End DoDot:1
if $DATA(DIRUT)
QUIT
+43 ; if ALL staff selected then get them from staff file
+44 IF ACKSS>3
Begin DoDot:1
+45 SET I=0
FOR
SET I=$ORDER(^ACK(509850.3,I))
if 'I
QUIT
Begin DoDot:2
+46 SET X=$PIECE(^ACK(509850.3,I,0),U,2)
+47 IF X=""
QUIT
+48 IF ACKSS=4
IF "CF"'[X
QUIT
+49 IF ACKSS=5
IF X'="O"
QUIT
+50 IF ACKSS=6
IF X'="S"
QUIT
+51 ;*17 Update to correctly set DUZ
+52 ;S ACKSTF(I)=$P(^ACK(509850.3,I,0),U)
+53 SET ACKSTF(I)=$$CONVERT1^ACKQUTL4(I)
End DoDot:2
End DoDot:1
+54 ;
+55 ; end
+56 QUIT
+57 ;
GETDIV(DIVARR,ACKSTA,ACKOPT) ; get all the Divisions and put them in DIVARR
+1 ; INPUT: DIVARR must be passed by reference
+2 ; ACKSTA division status (optional)
+3 ; 'A' will get active divisions only (default)
+4 ; 'I' will get inactive divisions only
+5 ; 'AI' or 'IA' will get all divisions
+6 ; ACKOPT options. so far the only option is 'U' to output the
+7 ; names in uppercase.
+8 ; RETURNS: DIVARR= number found (n)
+9 ; DIVARR(1,n)=x^y^name
+10 ; DIVARR(2,name)=n
+11 ; and DIVARR(3,x)=n
+12 ; where x=IEN of Div from Medical Center Division file
+13 ; and y=sequence number from A&SP Site Parameter file
+14 ; (in other words ^ACK(509850.8,1,2,y)=x^...)
+15 ; and name=the division name
+16 ;
+17 NEW ACKTGT,ACKMSG,ACKSCRN,ACK,SEQ,DIV,DIVNAME
+18 KILL DIVARR
+19 ; build screen based on requested status
+20 IF $GET(ACKSTA)=""
SET ACKSTA="A"
+21 SET ACKSCRN="I """_ACKSTA_"""[$P(^(0),U,2)"
+22 ; go get 'em
+23 DO LIST^DIC(509850.83,",1,",".01","I","*","","","",ACKSCRN,"","ACKTGT","ACKMSG")
+24 ; now transfer to output array
+25 SET DIVARR=$PIECE(ACKTGT("DILIST",0),U,1)
+26 FOR ACK=1:1:DIVARR
Begin DoDot:1
+27 SET SEQ=ACKTGT("DILIST",2,ACK)
SET DIV=ACKTGT("DILIST",1,ACK)
+28 SET DIVNAME=$$GET1^DIQ(40.8,DIV_",",.01)
+29 SET DIVARR(1,ACK)=DIV_U_SEQ_U_DIVNAME
+30 SET DIVARR(2,$$UP($GET(ACKOPT),DIVNAME))=ACK
+31 SET DIVARR(3,DIV)=ACK
End DoDot:1
+32 QUIT
UP(ACKOPT,X) ; convert X to uppercase (if requested)
+1 IF ACKOPT["U"
QUIT $TRANSLATE(X,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+2 QUIT X
+3 ;
STOPSORT(ACKASB,ACKVSC) ; determine stop code sort value
+1 ; this function determines whether the Stop Code for the Visit is
+2 ; valid for the type of report selected.
+3 ; If it is not valid the function returns 0
+4 ; If it is valid the function returns an integer which may be used to
+5 ; sequence the visit so that Audio comes first, Audio/Tel next,
+6 ; then Speech and Speech/Tel.
+7 ; If an unknown Visit Stop Code is encountered, it is given a 9
+8 ; which means it will appear at the end of the report as UNKNOWN.
+9 ; audiology #1
IF ACKVSC="A"
QUIT $SELECT(ACKASB="A":1,ACKASB="B":1,1:0)
+10 ; telephone audiology #2
IF ACKVSC="AT"
QUIT $SELECT(ACKASB="A":2,ACKASB="B":2,1:0)
+11 ; speech #3
IF ACKVSC="S"
QUIT $SELECT(ACKASB="S":3,ACKASB="B":3,1:0)
+12 ; telephone speech #4
IF ACKVSC="ST"
QUIT $SELECT(ACKASB="S":4,ACKASB="B":4,1:0)
+13 ; any other value 9
QUIT 9
+14 ;
STOPNM(ACKSORT) ; convert stop code sort value into a stop code name
+1 IF ACKSORT=1
QUIT "AUDIOLOGY"
+2 IF ACKSORT=2
QUIT "AUDIOLOGY TELEPHONE"
+3 IF ACKSORT=3
QUIT "SPEECH PATHOLOGY"
+4 IF ACKSORT=4
QUIT "SPEECH TELEPHONE"
+5 QUIT "UNKNOWN"
+6 ;
