- ACKQASU2 ;HCIOFO/BH-NEW/EDIT VISIT QUASAR UTILITIES ; 04/01/99
- ;;3.0;QUASAR;**1**;Feb 11, 2000
- ;Per VHA Directive 10-93-142, this routine SHOULD NOT be modified.
- ;
- ;
- ADD S ACKCNT=ACKCNT+1 Q
- ;
- ;
- ;
- POST(ACKVIEN) ;
- K DIRUT,DTOUT
- ;
- N ACKEXPT,ACKK1,ACKK2,ACKARR,ACK,ACKSC,VAEL,ACKVSC,ACKVAO,ACKVRAD,ACKVENV
- ;
- ; Clear away Update PCE Problem list and Diag provider if invalid
- N ACKPROB,ACKDD,ACKDREC,ACKDUP,ACKDPROV,ACKDIAG
- S ACKDIAG=0
- S ACKPROB=$$PROB^ACKQUTL4(ACKPCE,ACKDIV)
- F S ACKDIAG=$O(^ACK(509850.6,ACKVIEN,1,ACKDIAG)) Q:'ACKDIAG D
- . S ACKDREC=$G(^ACK(509850.6,ACKVIEN,1,ACKDIAG,0)) Q:'ACKDREC
- . S ACKDUP=$P(ACKDREC,"^",3)
- . S ACKDPROV=$P(ACKDREC,"^",4)
- . I 'ACKPROB D Q
- . . I ACKDUP'=""!(ACKDPROV'="") D
- . . . K ACKDD
- . . . S ACKDD(509850.63,ACKDIAG_","_ACKVIEN_",",.13)=""
- . . . S ACKDD(509850.63,ACKDIAG_","_ACKVIEN_",",.14)=""
- . . . D FILE^DIE("","ACKDD","") K ACKDD
- . I ACKPROB D Q
- . . I 'ACKDUP,ACKDPROV'="" D
- . . . K ACKDD
- . . . S ACKDD(509850.63,ACKDIAG_","_ACKVIEN_",",.14)=""
- . . . S ACKDD(509850.63,ACKDIAG_","_ACKVIEN_",",.13)=""
- . . . D FILE^DIE("","ACKDD","") K ACKDD
- ;
- ;------------------------------------------------
- D ELIG^VADPT S ACKSC=$P(VAEL(3),U,1) K VAEL
- ;
- GETDATA D GETS^DIQ(509850.6,ACKVIEN,"20;25;30;35","I","ACK")
- ;
- S ACKVSC=ACK(509850.6,ACKVIEN_",",20,"I")
- S ACKVAO=ACK(509850.6,ACKVIEN_",",25,"I")
- S ACKVRAD=ACK(509850.6,ACKVIEN_",",30,"I")
- S ACKVENV=ACK(509850.6,ACKVIEN_",",35,"I")
- ;
- K ACK
- ;
- NULL ; NUll out fields that should not bo present or have been set
- ; incorrectly
- ;
- I ACKSC=0,ACKVSC'="" S ACK(509850.6,ACKVIEN_",",20)="" S ACKVSC=""
- ;
- I ACKAO=0,ACKVAO'="" S ACK(509850.6,ACKVIEN_",",25)=""
- I ACKRAD=0,ACKVRAD'="" S ACK(509850.6,ACKVIEN_",",30)=""
- I ACKENV=0,ACKVENV'="" S ACK(509850.6,ACKVIEN_",",35)=""
- ;
- I ACKSC=1,ACKVSC=1,ACKVAO'="" S ACK(509850.6,ACKVIEN_",",25)=""
- I ACKSC=1,ACKVSC=1,ACKVRAD'="" S ACK(509850.6,ACKVIEN_",",30)=""
- I ACKSC=1,ACKVSC=1,ACKVENV'="" S ACK(509850.6,ACKVIEN_",",35)=""
- I $D(ACK) D FILE^DIE("","ACK") K ACK
- ;
- D CHKVST^ACKQUTL8(ACKVIEN,.ACKARR,1)
- ;
- I ACKARR=0 D MINIMUM G EXIT ; Minimum data not entered
- ;
- I ACKARR=-1 D CORRUPT,DELETE S ACKOUT=2 ; Corrupt
- ;
- I ACKARR=3 S ACKOUT=1 G EXIT ; Everything is okay
- ;
- I 'ACKPCE,ACKARR=2 S ACKOUT=1 G EXIT ; Interface off and no Quasar
- ; ; errors - Everything is okay
- ;
- I ACKPCE D
- . D PCE
- . S ACKK1="" F S ACKK1=$O(ACKARR(1,ACKK1)) Q:ACKK1="" D
- . . W !," ",ACKARR(1,ACKK1)
- . S ACKK2="" F S ACKK2=$O(ACKARR(2,ACKK2)) Q:ACKK2="" D
- . . W !," ",ACKARR(2,ACKK2)
- . S ACKEXPT=$$EXPT(ACKVIEN)
- . W !! D CHOICE1 W !!
- ;
- I 'ACKPCE D
- . D QUASAR
- . S ACKK1="" F S ACKK1=$O(ACKARR(1,ACKK1)) Q:ACKK1="" D
- . . W !," ",ACKARR(1,ACKK1)
- . W !! D CHOICE W !!
- ;
- EXIT ; One way out
- Q ACKOUT
- ;
- ;
- MINIMUM ; Minimum Data not entered. If New Visit user can either delete or
- ; re-edit the visit if user is editing a visit user only has option
- ; to re-edit the visit.
- ;
- D DISPLAY
- I ACKVISIT="NEW" D Q
- . K DIR
- . S DIR("A")="Enter RETURN to Re-Edit Visit or '^' to Quit and Delete"
- . S DIR(0)="E" D ^DIR K DIR
- . I $D(DTOUT)!$D(DIRUT) S X="^" ; Time out or Quit
- . I X="^" S ACKOUT=2 D DELETE Q
- . S ACKOUT=0 Q ; Entered <Return>
- ;
- I ACKVISIT="EDIT" D Q
- . K DIR
- . S DIR("?")="This option will not Quit until Quasars Minimum Data Requirements have been entered"
- . S DIR("A")="Press RETURN to Re-edit Visit",DIR(0)="E"
- . D ^DIR
- . S ACKOUT=0 Q
- ;
- ;
- DELETE ; Delete the entry
- ;
- W !!,$C(7),"<<INCOMPLETE RECORD DELETED!!>>",!!
- S DIK="^ACK(509850.6,",DA=ACKVIEN D ^DIK
- Q
- ;
- ;
- CORRUPT ; Display corrupt data message
- ;
- W !!,"ERROR - This record has become corrupted.",!
- ;
- Q
- ;
- QUASAR ; Display Quasar heading and missing fields
- ;
- W !!," WARNING - ",!
- W " The following are fields required by QUASAR that have not been entered.",!
- W " Enter <RETURN> to re-enter this function or '^' to quit.",!!
- ;
- Q
- ;
- PCE ; Display PCE missing fields
- ;
- W @IOF
- W " WARNING - ",!!
- W " The following are fields required by QUASAR & PCE that have not been entered.",!
- Q
- ;
- PCE1 W !," '^' Quit & File the A&SP visit but do not send incomplete A&SP"
- W !," visit to PCE. Or,"
- ;
- Q
- ;
- CHOICE ; Display choice - either enter '^' to quit entry or <Return> to
- ; re-enter the template
- ;
- K DIR S DIR(0)="E" D ^DIR K DIR
- I +Y=1 S ACKOUT=0
- I +Y=0 S ACKOUT=1
- S:$D(DIRUT) ACKOUT=1
- K DIRUT,DTOUT
- Q
- ;
- CHOICE1 ; Prompt for PCE choice - An Exception may not be set when the PCE Inte-
- ; -face is on so dont prompt user with 'Send to PCE' options if no
- ; exception is present (i.e. ACKEXPT=0).
- ;
- ; If EXCEPTION '^' - Quit but not send to PCE
- ; R - Re-enter the template
- ; C - Continue send with errors
- ; '^' - Returns 2 C - Returns 1 R - Returns 0
- ;
- ; If not EXCEPTION '^' - Quit
- ; R - Re-enter the template
- ; C - Continue file with errors
- ; '^' & C - Returns 2 R - Returns 0
- ;
- DISP I ACKEXPT D PCE1
- S DIR("A")=" (C)ontinue or (R)enter "
- S DIR("B")="R"
- I ACKEXPT S DIR("?")=" Enter 'R' to Re-enter this function and amend data, 'C' to Continue and send incomplete A&SP visit data to PCE or '^' to exit without sending to PCE."
- I ACKEXPT'=1 S DIR("?")=" Enter 'R' to Re-enter this function and amend data or 'C' to Continue and file incomplete"
- I ACKEXPT S DIR(0)="S^R:Re-enter this function & amend data;C:Continue & send incomplete A&SP visit data to PCE;"
- I ACKEXPT'=1 S DIR(0)="S^R:Re-enter this function & amend data;C:Continue & file incomplete;"
- D ^DIR K DIR
- S:$D(DTOUT) X=U
- S:$D(DIRUT) ACKOUT=2
- I ACKEXPT I X="c"!(X="C") S ACKOUT=1
- I ACKEXPT'=1 I X="c"!(X="C") S ACKOUT=2
- I X="r"!(X="R") S ACKOUT=0
- I X="^" S ACKOUT=2
- ;
- Q
- ;
- UTLAUD ;
- N ACK,ACKRAV,ACKLAV,ACKI,ACKR1,ACKR2,ACKR3,ACKR4,ACKL1,ACKL2,ACKL3,ACKL4
- N ACKAR
- ; Sets previous vist audiometric data into file
- ;
- I $L($G(ACKLAMD))>7 D Q
- . F ACKI=1:1:16 S $P(^ACK(509850.6,ACKVIEN,4),U,ACKI)=$P(ACKLAMD,U,ACKI+1)
- ;
- ;
- ; Calculates the average of the scores and sets the results into
- ; visit file
- ;
- D VALUES
- ;
- ; Cannot calculate average if a null value exists
- I ACKR1=""!(ACKR2="")!(ACKR3="")!(ACKR4="") G LEFT
- S ACKRAV=ACKR1+ACKR2+ACKR3+ACKR4/4+.5\1 S:ACKRAV<0 ACKRAV=0
- S ACKAR(509850.6,ACKVIEN_",","4.06")=ACKRAV
- ;
- LEFT ; Cannot calculate average if a null value exists
- I ACKL1=""!(ACKL2="")!(ACKL3="")!(ACKL4="") Q
- S ACKLAV=ACKL1+ACKL2+ACKL3+ACKL4/4+.5\1 S:ACKLAV<0 ACKLAV=0
- S ACKAR(509850.6,ACKVIEN_",","4.12")=ACKLAV
- D FILE^DIE("K","ACKAR") K ACKAR
- ;
- Q
- ;
- VALUES ; Get value for calculation
- K ACK
- D GETS^DIQ(509850.6,ACKVIEN,"4.02;4.03;4.04;4.05;4.08;4.09;4.1;4.11","I","ACK")
- ;
- S ACKR1=ACK(509850.6,ACKVIEN_",",4.02,"I")
- S ACKR2=ACK(509850.6,ACKVIEN_",",4.03,"I")
- S ACKR3=ACK(509850.6,ACKVIEN_",",4.04,"I")
- S ACKR4=ACK(509850.6,ACKVIEN_",",4.05,"I")
- ;
- S ACKL1=ACK(509850.6,ACKVIEN_",",4.08,"I")
- S ACKL2=ACK(509850.6,ACKVIEN_",",4.09,"I")
- S ACKL3=ACK(509850.6,ACKVIEN_",",4.1,"I")
- S ACKL4=ACK(509850.6,ACKVIEN_",",4.11,"I")
- ;
- K ACK
- Q
- ;
- EXPT(ACKVIEN) ; Passes back 1 or zero depending if visit has an Exception
- ; entry set up.
- N ACKEX
- S ACKEX=$$GET1^DIQ(509850.6,ACKVIEN_",",900,"I") I ACKEX="" Q 0
- I '$D(^ACK(509850.6,"AEX",ACKEX,ACKVIEN)) Q 0
- Q 1
- ;
- ;
- DISPLAY ;
- W !!,"The following field(s) are required by QUASAR but have not been entered.",!!
- I $$GET1^DIQ(509850.6,ACKVIEN_",",5)="" W " CDR Account",!
- I $$GET1^DIQ(509850.6,ACKVIEN_",",55)="" W " Appointment Time",!
- W !!
- Q
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HACKQASU2 8093 printed Feb 18, 2025@23:58:18 Page 2
- ACKQASU2 ;HCIOFO/BH-NEW/EDIT VISIT QUASAR UTILITIES ; 04/01/99
- +1 ;;3.0;QUASAR;**1**;Feb 11, 2000
- +2 ;Per VHA Directive 10-93-142, this routine SHOULD NOT be modified.
- +3 ;
- +4 ;
- ADD SET ACKCNT=ACKCNT+1
- QUIT
- +1 ;
- +2 ;
- +3 ;
- POST(ACKVIEN) ;
- +1 KILL DIRUT,DTOUT
- +2 ;
- +3 NEW ACKEXPT,ACKK1,ACKK2,ACKARR,ACK,ACKSC,VAEL,ACKVSC,ACKVAO,ACKVRAD,ACKVENV
- +4 ;
- +5 ; Clear away Update PCE Problem list and Diag provider if invalid
- +6 NEW ACKPROB,ACKDD,ACKDREC,ACKDUP,ACKDPROV,ACKDIAG
- +7 SET ACKDIAG=0
- +8 SET ACKPROB=$$PROB^ACKQUTL4(ACKPCE,ACKDIV)
- +9 FOR
- SET ACKDIAG=$ORDER(^ACK(509850.6,ACKVIEN,1,ACKDIAG))
- if 'ACKDIAG
- QUIT
- Begin DoDot:1
- +10 SET ACKDREC=$GET(^ACK(509850.6,ACKVIEN,1,ACKDIAG,0))
- if 'ACKDREC
- QUIT
- +11 SET ACKDUP=$PIECE(ACKDREC,"^",3)
- +12 SET ACKDPROV=$PIECE(ACKDREC,"^",4)
- +13 IF 'ACKPROB
- Begin DoDot:2
- +14 IF ACKDUP'=""!(ACKDPROV'="")
- Begin DoDot:3
- +15 KILL ACKDD
- +16 SET ACKDD(509850.63,ACKDIAG_","_ACKVIEN_",",.13)=""
- +17 SET ACKDD(509850.63,ACKDIAG_","_ACKVIEN_",",.14)=""
- +18 DO FILE^DIE("","ACKDD","")
- KILL ACKDD
- End DoDot:3
- End DoDot:2
- QUIT
- +19 IF ACKPROB
- Begin DoDot:2
- +20 IF 'ACKDUP
- IF ACKDPROV'=""
- Begin DoDot:3
- +21 KILL ACKDD
- +22 SET ACKDD(509850.63,ACKDIAG_","_ACKVIEN_",",.14)=""
- +23 SET ACKDD(509850.63,ACKDIAG_","_ACKVIEN_",",.13)=""
- +24 DO FILE^DIE("","ACKDD","")
- KILL ACKDD
- End DoDot:3
- End DoDot:2
- QUIT
- End DoDot:1
- +25 ;
- +26 ;------------------------------------------------
- +27 DO ELIG^VADPT
- SET ACKSC=$PIECE(VAEL(3),U,1)
- KILL VAEL
- +28 ;
- GETDATA DO GETS^DIQ(509850.6,ACKVIEN,"20;25;30;35","I","ACK")
- +1 ;
- +2 SET ACKVSC=ACK(509850.6,ACKVIEN_",",20,"I")
- +3 SET ACKVAO=ACK(509850.6,ACKVIEN_",",25,"I")
- +4 SET ACKVRAD=ACK(509850.6,ACKVIEN_",",30,"I")
- +5 SET ACKVENV=ACK(509850.6,ACKVIEN_",",35,"I")
- +6 ;
- +7 KILL ACK
- +8 ;
- NULL ; NUll out fields that should not bo present or have been set
- +1 ; incorrectly
- +2 ;
- +3 IF ACKSC=0
- IF ACKVSC'=""
- SET ACK(509850.6,ACKVIEN_",",20)=""
- SET ACKVSC=""
- +4 ;
- +5 IF ACKAO=0
- IF ACKVAO'=""
- SET ACK(509850.6,ACKVIEN_",",25)=""
- +6 IF ACKRAD=0
- IF ACKVRAD'=""
- SET ACK(509850.6,ACKVIEN_",",30)=""
- +7 IF ACKENV=0
- IF ACKVENV'=""
- SET ACK(509850.6,ACKVIEN_",",35)=""
- +8 ;
- +9 IF ACKSC=1
- IF ACKVSC=1
- IF ACKVAO'=""
- SET ACK(509850.6,ACKVIEN_",",25)=""
- +10 IF ACKSC=1
- IF ACKVSC=1
- IF ACKVRAD'=""
- SET ACK(509850.6,ACKVIEN_",",30)=""
- +11 IF ACKSC=1
- IF ACKVSC=1
- IF ACKVENV'=""
- SET ACK(509850.6,ACKVIEN_",",35)=""
- +12 IF $DATA(ACK)
- DO FILE^DIE("","ACK")
- KILL ACK
- +13 ;
- +14 DO CHKVST^ACKQUTL8(ACKVIEN,.ACKARR,1)
- +15 ;
- +16 ; Minimum data not entered
- IF ACKARR=0
- DO MINIMUM
- GOTO EXIT
- +17 ;
- +18 ; Corrupt
- IF ACKARR=-1
- DO CORRUPT
- DO DELETE
- SET ACKOUT=2
- +19 ;
- +20 ; Everything is okay
- IF ACKARR=3
- SET ACKOUT=1
- GOTO EXIT
- +21 ;
- +22 ; Interface off and no Quasar
- IF 'ACKPCE
- IF ACKARR=2
- SET ACKOUT=1
- GOTO EXIT
- +23 ; ; errors - Everything is okay
- +24 ;
- +25 IF ACKPCE
- Begin DoDot:1
- +26 DO PCE
- +27 SET ACKK1=""
- FOR
- SET ACKK1=$ORDER(ACKARR(1,ACKK1))
- if ACKK1=""
- QUIT
- Begin DoDot:2
- +28 WRITE !," ",ACKARR(1,ACKK1)
- End DoDot:2
- +29 SET ACKK2=""
- FOR
- SET ACKK2=$ORDER(ACKARR(2,ACKK2))
- if ACKK2=""
- QUIT
- Begin DoDot:2
- +30 WRITE !," ",ACKARR(2,ACKK2)
- End DoDot:2
- +31 SET ACKEXPT=$$EXPT(ACKVIEN)
- +32 WRITE !!
- DO CHOICE1
- WRITE !!
- End DoDot:1
- +33 ;
- +34 IF 'ACKPCE
- Begin DoDot:1
- +35 DO QUASAR
- +36 SET ACKK1=""
- FOR
- SET ACKK1=$ORDER(ACKARR(1,ACKK1))
- if ACKK1=""
- QUIT
- Begin DoDot:2
- +37 WRITE !," ",ACKARR(1,ACKK1)
- End DoDot:2
- +38 WRITE !!
- DO CHOICE
- WRITE !!
- End DoDot:1
- +39 ;
- EXIT ; One way out
- +1 QUIT ACKOUT
- +2 ;
- +3 ;
- MINIMUM ; Minimum Data not entered. If New Visit user can either delete or
- +1 ; re-edit the visit if user is editing a visit user only has option
- +2 ; to re-edit the visit.
- +3 ;
- +4 DO DISPLAY
- +5 IF ACKVISIT="NEW"
- Begin DoDot:1
- +6 KILL DIR
- +7 SET DIR("A")="Enter RETURN to Re-Edit Visit or '^' to Quit and Delete"
- +8 SET DIR(0)="E"
- DO ^DIR
- KILL DIR
- +9 ; Time out or Quit
- IF $DATA(DTOUT)!$DATA(DIRUT)
- SET X="^"
- +10 IF X="^"
- SET ACKOUT=2
- DO DELETE
- QUIT
- +11 ; Entered <Return>
- SET ACKOUT=0
- QUIT
- End DoDot:1
- QUIT
- +12 ;
- +13 IF ACKVISIT="EDIT"
- Begin DoDot:1
- +14 KILL DIR
- +15 SET DIR("?")="This option will not Quit until Quasars Minimum Data Requirements have been entered"
- +16 SET DIR("A")="Press RETURN to Re-edit Visit"
- SET DIR(0)="E"
- +17 DO ^DIR
- +18 SET ACKOUT=0
- QUIT
- End DoDot:1
- QUIT
- +19 ;
- +20 ;
- DELETE ; Delete the entry
- +1 ;
- +2 WRITE !!,$CHAR(7),"<<INCOMPLETE RECORD DELETED!!>>",!!
- +3 SET DIK="^ACK(509850.6,"
- SET DA=ACKVIEN
- DO ^DIK
- +4 QUIT
- +5 ;
- +6 ;
- CORRUPT ; Display corrupt data message
- +1 ;
- +2 WRITE !!,"ERROR - This record has become corrupted.",!
- +3 ;
- +4 QUIT
- +5 ;
- QUASAR ; Display Quasar heading and missing fields
- +1 ;
- +2 WRITE !!," WARNING - ",!
- +3 WRITE " The following are fields required by QUASAR that have not been entered.",!
- +4 WRITE " Enter <RETURN> to re-enter this function or '^' to quit.",!!
- +5 ;
- +6 QUIT
- +7 ;
- PCE ; Display PCE missing fields
- +1 ;
- +2 WRITE @IOF
- +3 WRITE " WARNING - ",!!
- +4 WRITE " The following are fields required by QUASAR & PCE that have not been entered.",!
- +5 QUIT
- +6 ;
- PCE1 WRITE !," '^' Quit & File the A&SP visit but do not send incomplete A&SP"
- +1 WRITE !," visit to PCE. Or,"
- +2 ;
- +3 QUIT
- +4 ;
- CHOICE ; Display choice - either enter '^' to quit entry or <Return> to
- +1 ; re-enter the template
- +2 ;
- +3 KILL DIR
- SET DIR(0)="E"
- DO ^DIR
- KILL DIR
- +4 IF +Y=1
- SET ACKOUT=0
- +5 IF +Y=0
- SET ACKOUT=1
- +6 if $DATA(DIRUT)
- SET ACKOUT=1
- +7 KILL DIRUT,DTOUT
- +8 QUIT
- +9 ;
- CHOICE1 ; Prompt for PCE choice - An Exception may not be set when the PCE Inte-
- +1 ; -face is on so dont prompt user with 'Send to PCE' options if no
- +2 ; exception is present (i.e. ACKEXPT=0).
- +3 ;
- +4 ; If EXCEPTION '^' - Quit but not send to PCE
- +5 ; R - Re-enter the template
- +6 ; C - Continue send with errors
- +7 ; '^' - Returns 2 C - Returns 1 R - Returns 0
- +8 ;
- +9 ; If not EXCEPTION '^' - Quit
- +10 ; R - Re-enter the template
- +11 ; C - Continue file with errors
- +12 ; '^' & C - Returns 2 R - Returns 0
- +13 ;
- DISP IF ACKEXPT
- DO PCE1
- +1 SET DIR("A")=" (C)ontinue or (R)enter "
- +2 SET DIR("B")="R"
- +3 IF ACKEXPT
- SET DIR("?")=" Enter 'R' to Re-enter this function and amend data, 'C' to Continue and send incomplete A&SP visit data to PCE or '^' to exit without sending to PCE."
- +4 IF ACKEXPT'=1
- SET DIR("?")=" Enter 'R' to Re-enter this function and amend data or 'C' to Continue and file incomplete"
- +5 IF ACKEXPT
- SET DIR(0)="S^R:Re-enter this function & amend data;C:Continue & send incomplete A&SP visit data to PCE;"
- +6 IF ACKEXPT'=1
- SET DIR(0)="S^R:Re-enter this function & amend data;C:Continue & file incomplete;"
- +7 DO ^DIR
- KILL DIR
- +8 if $DATA(DTOUT)
- SET X=U
- +9 if $DATA(DIRUT)
- SET ACKOUT=2
- +10 IF ACKEXPT
- IF X="c"!(X="C")
- SET ACKOUT=1
- +11 IF ACKEXPT'=1
- IF X="c"!(X="C")
- SET ACKOUT=2
- +12 IF X="r"!(X="R")
- SET ACKOUT=0
- +13 IF X="^"
- SET ACKOUT=2
- +14 ;
- +15 QUIT
- +16 ;
- UTLAUD ;
- +1 NEW ACK,ACKRAV,ACKLAV,ACKI,ACKR1,ACKR2,ACKR3,ACKR4,ACKL1,ACKL2,ACKL3,ACKL4
- +2 NEW ACKAR
- +3 ; Sets previous vist audiometric data into file
- +4 ;
- +5 IF $LENGTH($GET(ACKLAMD))>7
- Begin DoDot:1
- +6 FOR ACKI=1:1:16
- SET $PIECE(^ACK(509850.6,ACKVIEN,4),U,ACKI)=$PIECE(ACKLAMD,U,ACKI+1)
- End DoDot:1
- QUIT
- +7 ;
- +8 ;
- +9 ; Calculates the average of the scores and sets the results into
- +10 ; visit file
- +11 ;
- +12 DO VALUES
- +13 ;
- +14 ; Cannot calculate average if a null value exists
- +15 IF ACKR1=""!(ACKR2="")!(ACKR3="")!(ACKR4="")
- GOTO LEFT
- +16 SET ACKRAV=ACKR1+ACKR2+ACKR3+ACKR4/4+.5\1
- if ACKRAV<0
- SET ACKRAV=0
- +17 SET ACKAR(509850.6,ACKVIEN_",","4.06")=ACKRAV
- +18 ;
- LEFT ; Cannot calculate average if a null value exists
- +1 IF ACKL1=""!(ACKL2="")!(ACKL3="")!(ACKL4="")
- QUIT
- +2 SET ACKLAV=ACKL1+ACKL2+ACKL3+ACKL4/4+.5\1
- if ACKLAV<0
- SET ACKLAV=0
- +3 SET ACKAR(509850.6,ACKVIEN_",","4.12")=ACKLAV
- +4 DO FILE^DIE("K","ACKAR")
- KILL ACKAR
- +5 ;
- +6 QUIT
- +7 ;
- VALUES ; Get value for calculation
- +1 KILL ACK
- +2 DO GETS^DIQ(509850.6,ACKVIEN,"4.02;4.03;4.04;4.05;4.08;4.09;4.1;4.11","I","ACK")
- +3 ;
- +4 SET ACKR1=ACK(509850.6,ACKVIEN_",",4.02,"I")
- +5 SET ACKR2=ACK(509850.6,ACKVIEN_",",4.03,"I")
- +6 SET ACKR3=ACK(509850.6,ACKVIEN_",",4.04,"I")
- +7 SET ACKR4=ACK(509850.6,ACKVIEN_",",4.05,"I")
- +8 ;
- +9 SET ACKL1=ACK(509850.6,ACKVIEN_",",4.08,"I")
- +10 SET ACKL2=ACK(509850.6,ACKVIEN_",",4.09,"I")
- +11 SET ACKL3=ACK(509850.6,ACKVIEN_",",4.1,"I")
- +12 SET ACKL4=ACK(509850.6,ACKVIEN_",",4.11,"I")
- +13 ;
- +14 KILL ACK
- +15 QUIT
- +16 ;
- EXPT(ACKVIEN) ; Passes back 1 or zero depending if visit has an Exception
- +1 ; entry set up.
- +2 NEW ACKEX
- +3 SET ACKEX=$$GET1^DIQ(509850.6,ACKVIEN_",",900,"I")
- IF ACKEX=""
- QUIT 0
- +4 IF '$DATA(^ACK(509850.6,"AEX",ACKEX,ACKVIEN))
- QUIT 0
- +5 QUIT 1
- +6 ;
- +7 ;
- DISPLAY ;
- +1 WRITE !!,"The following field(s) are required by QUASAR but have not been entered.",!!
- +2 IF $$GET1^DIQ(509850.6,ACKVIEN_",",5)=""
- WRITE " CDR Account",!
- +3 IF $$GET1^DIQ(509850.6,ACKVIEN_",",55)=""
- WRITE " Appointment Time",!
- +4 WRITE !!
- +5 QUIT
- +6 ;