- 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 Feb 18, 2025@23:59:04 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 ;
