source: FOIAVistA/trunk/r/QUASAR-ACKQ/ACKQCP1.m@ 707

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
 ;