ACKQCP1 ;AUG/JLTP BIR/PTD HCIOFO/BH-QUASAR/C&P Interface - CONTINUED ; [ 04/24/96 1:20 PM ]
;;3.0;QUASAR;;Feb 11, 2000
; Per VHA Directive 10-93-142, this routine SHOULD NOT be modified.
PULL ; Pulls QUASAR data into ACKC array to pass to AMIE package.
; ENTER WITH: ACKD0=IFN from QUASAR Visit file, DFN=Patient#
;
D DEM^VADPT S ACKQRAW=$G(^ACK(509850.6,ACKD0,4)),ACK0=^(0),ACK2=^(2) K ACKC
S ACKC(1)=" ",ACKC(2)="PATIENT: "_$$GET1^DIQ(2,DFN,.01)_" ("_$P(VADM(2),"^",2)_")" S Y=$P(ACK0,"^") I Y'="" X ^DD("DD") S ACKC(3)="A&SP CLINIC VISIT DATE: "_Y
S ACKDIV=$P(^ACK(509850.6,ACKD0,5),U,1)
S ACKDSTAT=$$GET1^DIQ(40.8,ACKDIV,1)
I ACKDIV'="" S ACKDIV=$$GET1^DIQ(40.8,ACKDIV,.01)
S ACKC(4)="DIVISION: "_$S($D(ACKDIV):ACKDIV,1:"No Division on file for Visit")
S ACKC(5)="STATION NUMBER: "_$S($D(ACKDSTAT):ACKDSTAT,1:"No station Number set up for Division")
;
;
F100 S ACKC(6)=" ",ACKCNT=7 I $O(^ACK(509850.6,ACKD0,100,0)) S ACKC(ACKCNT)="REVIEW OF MEDICAL RECORDS:" S ACKFLD=100 D FLD S ACKCNT=ACKCNT+1,ACKC(ACKCNT)=" "
F101 S ACKCNT=ACKCNT+1 I $O(^ACK(509850.6,ACKD0,101,0)) S ACKC(ACKCNT)="MEDICAL HISTORY (SUBJECTIVE COMPLAINTS):" S ACKFLD=101 D FLD S ACKCNT=ACKCNT+1,ACKC(ACKCNT)=" "
F102 S ACKCNT=ACKCNT+1,ACKC(ACKCNT)="PHYSICAL EXAMINATION (OBJECTIVE FINDINGS):",ACKCNT=ACKCNT+1
S X="R500: ^R1000: ^R2000: ^R3000: ^R4000: ^R AVG: ^L500: ^L1000: ^L2000: ^L3000: ^L4000: ^L AVG: "
S ACKC(ACKCNT)="Pure Tone Results:",ACKCNT=ACKCNT+1
F I=1:1:6 S X1=$P(X,U,I)_$$J($P(ACKQRAW,U,I)),X1=X1_" "_$P(X,U,I+6)_$$J($P(ACKQRAW,U,I+6)),ACKC(ACKCNT)=X1,ACKCNT=ACKCNT+1
S ACKC(ACKCNT)=" ",ACKCNT=ACKCNT+1,ACKC(ACKCNT)="Speech Recognition Scores:",ACKCNT=ACKCNT+1,ACKC(ACKCNT)="CNC R: "_$$J($P(ACKQRAW,U,13))_" CNC L: "_$$J($P(ACKQRAW,U,14)),ACKCNT=ACKCNT+1
S ACKC(ACKCNT)="W22 R: "_$$J($P(ACKQRAW,U,15))_" W22 L: "_$$J($P(ACKQRAW,U,16)),ACKCNT=ACKCNT+1,ACKC(ACKCNT)=" "
I $O(^ACK(509850.6,ACKD0,102,0)) S ACKFLD=102 D FLD S ACKCNT=ACKCNT+1,ACKC(ACKCNT)=" "
F103 S ACKCNT=ACKCNT+1 I $O(^ACK(509850.6,ACKD0,103,0)) S ACKC(ACKCNT)="DIAGNOSTIC AND CLINICAL TESTS:" S ACKFLD=103 D FLD S ACKCNT=ACKCNT+1,ACKC(ACKCNT)=" "
F104 S ACKCNT=ACKCNT+1 I $O(^ACK(509850.6,ACKD0,104,0)) S ACKC(ACKCNT)="DIAGNOSIS:" S ACKFLD=104 D FLD S ACKCNT=ACKCNT+1,ACKC(ACKCNT)=" "
S ACKCNT=ACKCNT+1,Y=$P(ACKQRAW,"^",18) I Y'="" X ^DD("DD") S ACKC(ACKCNT)="Completion Date: "_Y,ACKCNT=ACKCNT+1,ACKC(ACKCNT)=$P($G(ACKQRAW),"^",17),ACKCNT=ACKCNT+1,ACKC(ACKCNT)=$P($G(ACKQRAW),"^",24),ACKCNT=ACKCNT+1,ACKC(ACKCNT)=" "
S ACKCNT=ACKCNT+1,Y=$P(ACKQRAW,"^",20) I Y'="" X ^DD("DD") S ACKC(ACKCNT)="Adequation Date: "_Y,ACKCNT=ACKCNT+1,ACKC(ACKCNT)=$P($G(ACKQRAW),"^",19),ACKCNT=ACKCNT+1,ACKC(ACKCNT)=$P($G(ACKQRAW),"^",25)
Q
;
;
FLD ; Build TMP array for audiometric fields.
S ACKI=0 F S ACKI=$O(^ACK(509850.6,ACKD0,ACKFLD,ACKI)) Q:'ACKI S ACKCNT=ACKCNT+1,ACKC(ACKCNT)=^ACK(509850.6,ACKD0,ACKFLD,ACKI,0)
Q
;
J(X) ; JUSTIFY PROPERLY
Q $S(X="":"",1:$J(X,3,0))
;
CP ; Select any C&P clinic visit.
S DIC=509850.6,DIC(0)="AEMQZ",DIC("A")="Select C&P VISIT DATE: ",DIC("S")="I $P(^(0),U,9)" W ! D ^DIC K DIC Q:Y<0 S ACKD0=+Y,DFN=+$P(Y(0),"^",2)
Q
;
PULL2 ; Pulls QUASAR data into ACKC array to display audiometric fields.
; Called from New Visit function.
;
; ENTER WITH: ACKD0=IFN from QUASAR Visit file, DFN=Patient#
;
D DEM^VADPT S ACKQRAW=$G(^ACK(509850.6,ACKD0,4)),ACK0=^(0),ACK2=^(2) K ACKC
S X="R500: ^R1000: ^R2000: ^R3000: ^R4000: ^R AVG: ^L500: ^L1000: ^L2000: ^L3000: ^L4000: ^L AVG: "
S ACKC(1)="PURE TONE RESULTS:"
F I=1:1:6 S X1=$P(X,U,I)_$$J($P(ACKQRAW,U,I)),X1=X1_" "_$P(X,U,I+6)_$$J($P(ACKQRAW,U,I+6)),ACKC(I+1)=X1
S ACKC(8)="SPEECH RECOGNITION SCORES:",ACKC(9)="CNC R: "_$$J($P(ACKQRAW,U,13))_" CNC L: "_$$J($P(ACKQRAW,U,14))
S ACKC(10)="W22 R: "_$$J($P(ACKQRAW,U,15))_" W22 L: "_$$J($P(ACKQRAW,U,16)),ACKC(11)=" "
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HACKQCP1 3972 printed Sep 02, 2024@19:17:26 Page 2
ACKQCP1 ;AUG/JLTP BIR/PTD HCIOFO/BH-QUASAR/C&P Interface - CONTINUED ; [ 04/24/96 1:20 PM ]
+1 ;;3.0;QUASAR;;Feb 11, 2000
+2 ; Per VHA Directive 10-93-142, this routine SHOULD NOT be modified.
PULL ; Pulls QUASAR data into ACKC array to pass to AMIE package.
+1 ; ENTER WITH: ACKD0=IFN from QUASAR Visit file, DFN=Patient#
+2 ;
+3 DO DEM^VADPT
SET ACKQRAW=$GET(^ACK(509850.6,ACKD0,4))
SET ACK0=^(0)
SET ACK2=^(2)
KILL ACKC
+4 SET ACKC(1)=" "
SET ACKC(2)="PATIENT: "_$$GET1^DIQ(2,DFN,.01)_" ("_$PIECE(VADM(2),"^",2)_")"
SET Y=$PIECE(ACK0,"^")
IF Y'=""
XECUTE ^DD("DD")
SET ACKC(3)="A&SP CLINIC VISIT DATE: "_Y
+5 SET ACKDIV=$PIECE(^ACK(509850.6,ACKD0,5),U,1)
+6 SET ACKDSTAT=$$GET1^DIQ(40.8,ACKDIV,1)
+7 IF ACKDIV'=""
SET ACKDIV=$$GET1^DIQ(40.8,ACKDIV,.01)
+8 SET ACKC(4)="DIVISION: "_$SELECT($DATA(ACKDIV):ACKDIV,1:"No Division on file for Visit")
+9 SET ACKC(5)="STATION NUMBER: "_$SELECT($DATA(ACKDSTAT):ACKDSTAT,1:"No station Number set up for Division")
+10 ;
+11 ;
F100 SET ACKC(6)=" "
SET ACKCNT=7
IF $ORDER(^ACK(509850.6,ACKD0,100,0))
SET ACKC(ACKCNT)="REVIEW OF MEDICAL RECORDS:"
SET ACKFLD=100
DO FLD
SET ACKCNT=ACKCNT+1
SET ACKC(ACKCNT)=" "
F101 SET ACKCNT=ACKCNT+1
IF $ORDER(^ACK(509850.6,ACKD0,101,0))
SET ACKC(ACKCNT)="MEDICAL HISTORY (SUBJECTIVE COMPLAINTS):"
SET ACKFLD=101
DO FLD
SET ACKCNT=ACKCNT+1
SET ACKC(ACKCNT)=" "
F102 SET ACKCNT=ACKCNT+1
SET ACKC(ACKCNT)="PHYSICAL EXAMINATION (OBJECTIVE FINDINGS):"
SET ACKCNT=ACKCNT+1
+1 SET X="R500: ^R1000: ^R2000: ^R3000: ^R4000: ^R AVG: ^L500: ^L1000: ^L2000: ^L3000: ^L4000: ^L AVG: "
+2 SET ACKC(ACKCNT)="Pure Tone Results:"
SET ACKCNT=ACKCNT+1
+3 FOR I=1:1:6
SET X1=$PIECE(X,U,I)_$$J($PIECE(ACKQRAW,U,I))
SET X1=X1_" "_$PIECE(X,U,I+6)_$$J($PIECE(ACKQRAW,U,I+6))
SET ACKC(ACKCNT)=X1
SET ACKCNT=ACKCNT+1
+4 SET ACKC(ACKCNT)=" "
SET ACKCNT=ACKCNT+1
SET ACKC(ACKCNT)="Speech Recognition Scores:"
SET ACKCNT=ACKCNT+1
SET ACKC(ACKCNT)="CNC R: "_$$J($PIECE(ACKQRAW,U,13))_" CNC L: "_$$J($PIECE(ACKQRAW,U,14))
SET ACKCNT=ACKCNT+1
+5 SET ACKC(ACKCNT)="W22 R: "_$$J($PIECE(ACKQRAW,U,15))_" W22 L: "_$$J($PIECE(ACKQRAW,U,16))
SET ACKCNT=ACKCNT+1
SET ACKC(ACKCNT)=" "
+6 IF $ORDER(^ACK(509850.6,ACKD0,102,0))
SET ACKFLD=102
DO FLD
SET ACKCNT=ACKCNT+1
SET ACKC(ACKCNT)=" "
F103 SET ACKCNT=ACKCNT+1
IF $ORDER(^ACK(509850.6,ACKD0,103,0))
SET ACKC(ACKCNT)="DIAGNOSTIC AND CLINICAL TESTS:"
SET ACKFLD=103
DO FLD
SET ACKCNT=ACKCNT+1
SET ACKC(ACKCNT)=" "
F104 SET ACKCNT=ACKCNT+1
IF $ORDER(^ACK(509850.6,ACKD0,104,0))
SET ACKC(ACKCNT)="DIAGNOSIS:"
SET ACKFLD=104
DO FLD
SET ACKCNT=ACKCNT+1
SET ACKC(ACKCNT)=" "
+1 SET ACKCNT=ACKCNT+1
SET Y=$PIECE(ACKQRAW,"^",18)
IF Y'=""
XECUTE ^DD("DD")
SET ACKC(ACKCNT)="Completion Date: "_Y
SET ACKCNT=ACKCNT+1
SET ACKC(ACKCNT)=$PIECE($GET(ACKQRAW),"^",17)
SET ACKCNT=ACKCNT+1
SET ACKC(ACKCNT)=$PIECE($GET(ACKQRAW),"^",24)
SET ACKCNT=ACKCNT+1
SET ACKC(ACKCNT)=" "
+2 SET ACKCNT=ACKCNT+1
SET Y=$PIECE(ACKQRAW,"^",20)
IF Y'=""
XECUTE ^DD("DD")
SET ACKC(ACKCNT)="Adequation Date: "_Y
SET ACKCNT=ACKCNT+1
SET ACKC(ACKCNT)=$PIECE($GET(ACKQRAW),"^",19)
SET ACKCNT=ACKCNT+1
SET ACKC(ACKCNT)=$PIECE($GET(ACKQRAW),"^",25)
+3 QUIT
+4 ;
+5 ;
FLD ; Build TMP array for audiometric fields.
+1 SET ACKI=0
FOR
SET ACKI=$ORDER(^ACK(509850.6,ACKD0,ACKFLD,ACKI))
if 'ACKI
QUIT
SET ACKCNT=ACKCNT+1
SET ACKC(ACKCNT)=^ACK(509850.6,ACKD0,ACKFLD,ACKI,0)
+2 QUIT
+3 ;
J(X) ; JUSTIFY PROPERLY
+1 QUIT $SELECT(X="":"",1:$JUSTIFY(X,3,0))
+2 ;
CP ; Select any C&P clinic visit.
+1 SET DIC=509850.6
SET DIC(0)="AEMQZ"
SET DIC("A")="Select C&P VISIT DATE: "
SET DIC("S")="I $P(^(0),U,9)"
WRITE !
DO ^DIC
KILL DIC
if Y<0
QUIT
SET ACKD0=+Y
SET DFN=+$PIECE(Y(0),"^",2)
+2 QUIT
+3 ;
PULL2 ; Pulls QUASAR data into ACKC array to display audiometric fields.
+1 ; Called from New Visit function.
+2 ;
+3 ; ENTER WITH: ACKD0=IFN from QUASAR Visit file, DFN=Patient#
+4 ;
+5 DO DEM^VADPT
SET ACKQRAW=$GET(^ACK(509850.6,ACKD0,4))
SET ACK0=^(0)
SET ACK2=^(2)
KILL ACKC
+6 SET X="R500: ^R1000: ^R2000: ^R3000: ^R4000: ^R AVG: ^L500: ^L1000: ^L2000: ^L3000: ^L4000: ^L AVG: "
+7 SET ACKC(1)="PURE TONE RESULTS:"
+8 FOR I=1:1:6
SET X1=$PIECE(X,U,I)_$$J($PIECE(ACKQRAW,U,I))
SET X1=X1_" "_$PIECE(X,U,I+6)_$$J($PIECE(ACKQRAW,U,I+6))
SET ACKC(I+1)=X1
+9 SET ACKC(8)="SPEECH RECOGNITION SCORES:"
SET ACKC(9)="CNC R: "_$$J($PIECE(ACKQRAW,U,13))_" CNC L: "_$$J($PIECE(ACKQRAW,U,14))
+10 SET ACKC(10)="W22 R: "_$$J($PIECE(ACKQRAW,U,15))_" W22 L: "_$$J($PIECE(ACKQRAW,U,16))
SET ACKC(11)=" "
+11 QUIT
+12 ;
