source: FOIAVistA/trunk/r/QUASAR-ACKQ/ACKQCPL.m@ 1119

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

initial load of FOIAVistA 6/30/08 version

File size: 3.0 KB
Line 
1ACKQCPL ;AUG/JLTP BIR/PTD HCIOFO/BH-Lookup for C&P Exams Awaiting Adequation ; 04/22/96 14:16
2 ;;3.0;QUASAR;;Feb 11, 2000
3 ;Per VHA Directive 10-93-142, this routine SHOULD NOT be modified.
4 ;
5BUILD ; Build array of exams user can adequate in ^TMP(.
6 N ACK5,ACKSTN,ACKDIV,ACKSTAT,ACKDUZ
7 S ACKDUZ=$$PROVCHK^ACKQASU4(DUZ) S:ACKDUZ="" ACKDUZ=" "
8 S ACKSUPER=$P($G(^ACK(509850.3,ACKDUZ,0)),U,6)
9 K ^TMP("ACKQCPL",$J) S (ACKWT,ACKCNT)=0 F S ACKWT=$O(^ACK(509850.6,"AWAIT",2,ACKWT)) Q:'ACKWT I ACKSUPER!($D(^ACK(509850.6,"ST",ACKDUZ,ACKWT))) D
10 .S ACKZNODE=$G(^ACK(509850.6,ACKWT,0))
11 .I $P(ACKZNODE,U,8),$$EN1^DVBCTRN($P(ACKZNODE,U,2),"AUDIO",$P(ACKZNODE,U,8))>0 D
12 ..S ACK5=$G(^ACK(509850.6,ACKWT,5))
13 ..S ACKCNT=ACKCNT+1,ACKDFN=$G(^DPT(+$P(ACKZNODE,U,2),0))
14 ..S Y=+ACKZNODE S:Y["." Y=$P(Y,".",1)
15 ..I $D(ACK5) S Y=Y_$P(ACK5,U,8) ; Concatenate App. time to Visit Date
16 ..X ^DD("DD") S Y=$P(Y,":",1,2),ACKVDT=Y,ACKSP=" "
17 ..S ACKSSN=$E($P(ACKDFN,U,9),1,3)_"-"_$E($P(ACKDFN,U,9),4,5)_"-"_$E($P(ACKDFN,U,9),6,9)
18 ..S ACKVDIV=$P(ACK5,U,1) ; Get division code
19 ..S ACKSTN=$$GET1^DIQ(40.8,ACKVDIV,1) ; Get Division Station Number
20 ..S ^TMP("ACKQCPL",$J,ACKCNT,ACKWT)=$E(ACKVDT_ACKSP,1,18)_$P(ACKDFN,U)_$E(ACKSP,$L($P(ACKDFN,U))+1,37)_ACKSSN_" "_$E(ACKSTN_ACKSP,1,7)
21 ; If no exams
22 I '$O(^TMP("ACKQCPL",$J,0)) D G EXIT
23 . W !,$C(7)
24 . W "No C&P exams awaiting adequation now." S DIRUT=1
25 ;
26 ; If only one exam
27 I ACKCNT=1 D G:$D(DIRUT) EXIT G SET
28 . W !,"There is only one C&P exam awaiting adequation.",!! D HEAD(0)
29 . W !,^TMP("ACKQCPL",$J,1,$O(^TMP("ACKQCPL",$J,1,0))),!!!
30 . ;
31 . S ACKVIEN=$O(^TMP("ACKQCPL",$J,1,0))
32 . W "Press RETURN to process this exam.",!
33 . S ACKNUM=1 S DIR(0)="E" D ^DIR K DIR Q:$D(DIRUT)
34 . ; Check this entry is not locked
35 . L +^ACK(509850.6,ACKVIEN):2 E W !!,"This record is locked by another process - Please try again later.",!! S DIRUT=1 Q
36 ;
37 ;
38CHOICE ; Display list of C&P exams to adequate.
39 D HEAD(1)
40 S ACKNUM=0 F S ACKNUM=$O(^TMP("ACKQCPL",$J,ACKNUM)) Q:'ACKNUM!($D(DIRUT)) D
41 .I $Y>(IOSL-5) D PAUSE^ACKQUTL Q:$D(DIRUT) W @IOF D HEAD(1)
42 .W !,$J(ACKNUM,3),". ",^TMP("ACKQCPL",$J,ACKNUM,$O(^TMP("ACKQCPL",$J,ACKNUM,0)))
43 ; Select one
44 I $D(DIRUT) G EXIT
45CHOICE1 S DIR(0)="NA^1:"_ACKCNT,DIR("A")="Select, by number, the exam you wish to adequate: ",DIR("?")="Choose a number from the list of exams"
46 W ! D ^DIR K DIR I $D(DIRUT) G EXIT
47 S ACKNUM=Y
48 ;
49SET ; Set ACKD0, ACKSFT, and DFN before exit and check for locking
50 S ACKD0=$O(^TMP("ACKQCPL",$J,ACKNUM,0))
51 ;
52 ; Check this entry is not locked
53 L +^ACK(509850.6,ACKD0):2 E W !!,"This record is locked by another process - Please try again later.",!! K ACKD0 G CHOICE1
54 ;
55 S DFN=+$P(^ACK(509850.6,ACKD0,0),U,2),ACKSFT=$P(^ACK(509850.6,ACKD0,0),U,8)
56 ;
57EXIT ; Kill variables and return to calling routine.
58 K ACKCNT,ACKDFN,ACKNUM,ACKSP,ACKSSN,ACKSUPER,ACKVDT,ACKWT,ACKZNODE
59 K DIR,X,Y,^TMP("ACKQCPL",$J),ACKVIEN
60 Q
61 ;
62HEAD(ACKX) ; Draws Heading on screen
63 W ! W:ACKX " " W "Visit Date/Time Name SSN Stn. #",!
64 Q
65 ;
66 ;
Note: See TracBrowser for help on using the repository browser.