source: FOIAVistA/tag/r/QUASAR-ACKQ/ACKQCP1.m@ 634

Last change on this file since 634 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version

File size: 3.8 KB
Line 
1ACKQCP1 ;AUG/JLTP BIR/PTD HCIOFO/BH-QUASAR/C&P Interface - CONTINUED ; [ 04/24/96 1:20 PM ]
2 ;;3.0;QUASAR;;Feb 11, 2000
3 ; Per VHA Directive 10-93-142, this routine SHOULD NOT be modified.
4PULL ; Pulls QUASAR data into ACKC array to pass to AMIE package.
5 ; ENTER WITH: ACKD0=IFN from QUASAR Visit file, DFN=Patient#
6 ;
7 D DEM^VADPT S ACKQRAW=$G(^ACK(509850.6,ACKD0,4)),ACK0=^(0),ACK2=^(2) K ACKC
8 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
9 S ACKDIV=$P(^ACK(509850.6,ACKD0,5),U,1)
10 S ACKDSTAT=$$GET1^DIQ(40.8,ACKDIV,1)
11 I ACKDIV'="" S ACKDIV=$$GET1^DIQ(40.8,ACKDIV,.01)
12 S ACKC(4)="DIVISION: "_$S($D(ACKDIV):ACKDIV,1:"No Division on file for Visit")
13 S ACKC(5)="STATION NUMBER: "_$S($D(ACKDSTAT):ACKDSTAT,1:"No station Number set up for Division")
14 ;
15 ;
16F100 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)=" "
17F101 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)=" "
18F102 S ACKCNT=ACKCNT+1,ACKC(ACKCNT)="PHYSICAL EXAMINATION (OBJECTIVE FINDINGS):",ACKCNT=ACKCNT+1
19 S X="R500: ^R1000: ^R2000: ^R3000: ^R4000: ^R AVG: ^L500: ^L1000: ^L2000: ^L3000: ^L4000: ^L AVG: "
20 S ACKC(ACKCNT)="Pure Tone Results:",ACKCNT=ACKCNT+1
21 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
22 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
23 S ACKC(ACKCNT)="W22 R: "_$$J($P(ACKQRAW,U,15))_" W22 L: "_$$J($P(ACKQRAW,U,16)),ACKCNT=ACKCNT+1,ACKC(ACKCNT)=" "
24 I $O(^ACK(509850.6,ACKD0,102,0)) S ACKFLD=102 D FLD S ACKCNT=ACKCNT+1,ACKC(ACKCNT)=" "
25F103 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)=" "
26F104 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)=" "
27 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)=" "
28 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)
29 Q
30 ;
31 ;
32FLD ; Build TMP array for audiometric fields.
33 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)
34 Q
35 ;
36J(X) ; JUSTIFY PROPERLY
37 Q $S(X="":"",1:$J(X,3,0))
38 ;
39CP ; Select any C&P clinic visit.
40 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)
41 Q
42 ;
43PULL2 ; Pulls QUASAR data into ACKC array to display audiometric fields.
44 ; Called from New Visit function.
45 ;
46 ; ENTER WITH: ACKD0=IFN from QUASAR Visit file, DFN=Patient#
47 ;
48 D DEM^VADPT S ACKQRAW=$G(^ACK(509850.6,ACKD0,4)),ACK0=^(0),ACK2=^(2) K ACKC
49 S X="R500: ^R1000: ^R2000: ^R3000: ^R4000: ^R AVG: ^L500: ^L1000: ^L2000: ^L3000: ^L4000: ^L AVG: "
50 S ACKC(1)="PURE TONE RESULTS:"
51 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
52 S ACKC(8)="SPEECH RECOGNITION SCORES:",ACKC(9)="CNC R: "_$$J($P(ACKQRAW,U,13))_" CNC L: "_$$J($P(ACKQRAW,U,14))
53 S ACKC(10)="W22 R: "_$$J($P(ACKQRAW,U,15))_" W22 L: "_$$J($P(ACKQRAW,U,16)),ACKC(11)=" "
54 Q
55 ;
Note: See TracBrowser for help on using the repository browser.