source: FOIAVistA/tag/r/QUASAR-ACKQ/ACKQCP.m@ 1416

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

initial load of FOIAVistA 6/30/08 version

File size: 5.5 KB
Line 
1ACKQCP ;AUG/JLTP BIR/PTD HCIOFO/BH-QUASAR/C&P Interface ; 06/06/99 11:51
2 ;;3.0;QUASAR;**1,2**;Feb 11, 2000
3 ;Per VHA Directive 10-93-142, this routine SHOULD NOT be modified.
4 ;;DBIA 1473 EN1^DVBCTRN & EN2^DVBCTRN
5 ;
6ADEQ ; Adequate a C&P Exam
7 N ACKDUZ
8 S ACKDUZ=$$PROVCHK^ACKQASU4(DUZ) S:ACKDUZ="" ACKDUZ=" "
9 I $O(^ACK(509850.3,ACKDUZ,""))="" W !,"You are not listed in the A&SP STAFF file (#509850.3).",!,"Access denied." G ADEX
10 S X=$$STACT^ACKQUTL(ACKDUZ) I (X=-2)!(X=-6) W !,"Only clinicians may adequate C&P exams!" G ADEX
11 I X W !,"The A&SP STAFF file (#509850.3) indicates that you have been inactivated.",!,"Access denied." G ADEX
12 ;
13OPTN ; Introduce option.
14 W @IOF
15 W !,"This option allows you to adequate C&P exams which currently have open"
16 W !,"requests in the AMIE software. An exam must be completed and signed off prior"
17 W !,"to adequation. You can use the Edit an Existing Visit option to review or edit"
18 W !,"an exam before adequating.",!
19 ;
20 D ^ACKQCPL G:$D(DIRUT) PRINT
21 D PULL^ACKQCP1,SHOW
22 ;
23 F I=1:1 S ACKTX=$P($T(ADEQWN+I),";;",2) Q:ACKTX="" W !,ACKTX
24 ;
25 S ACKMODE=2 D SIG^ACKQCP I '$D(ACKSIG) D UNLOCK G ADEX
26 ;
27 N ACKQVD,ACKQQPV,ACKQQPV1 S ACKQQPV1=""
28 I $$EN1^DVBCTRN(DFN,"AUDIO",ACKSFT)>0 D
29 . S DIE="^ACK(509850.6,",DA=ACKD0
30 . S DR="4.19////"_ACKSIG_";4.2////"_DT_";4.25////"_ACKTITL
31 . D ^DIE K ACKC D PULL^ACKQCP1
32 ;
33 S ACKQVD=$$GET1^DIQ(509850.6,ACKD0_",",.01,"I")
34 S ACKQQPV=$$GET1^DIQ(509850.6,ACKD0,6,"I")
35 I ACKQQPV'="" S ACKQQPV1=$$CONVERT1^ACKQUTL4(ACKQQPV)
36 I ACKQQPV1'="" S ACKST=$$EN2^DVBCTRN("ACKC","ACKQ",ACKSFT,ACKQQPV1,ACKQVD)
37 ;
38 I ACKQQPV1="" S ACKST=$$EN2^DVBCTRN("ACKC","ACKQ",ACKSFT,"",ACKQVD)
39 ;
40 I ACKST>0 D
41 . N ACKQARR
42 . S ACKQARR(509850.6,ACKD0_",",.09)="3" D FILE^DIE("","ACKQARR","")
43 . I $D(^ACK(509850.6,"AWAIT",2,ACKD0)) K ^ACK(509850.6,"AWAIT",2,ACKD0)
44 . K ACKQARR
45 ;
46 I ACKST<0 W !!,$C(7),$P(ACKST,U,2),!,"Results NOT transferred!!" S DIE="^ACK(509850.6,",DA=ACKD0,DR="4.19///@;4.2///@;4.25///@" D ^DIE K DIE D UNLOCK G ADEX
47 ;
48 W !!,"Final results transferred to AMIE C&P package." D UNLOCK
49 ;
50PRINT I $D(ACKD0) S DIR(0)="Y",DIR("A")="Print a file copy NOW",DIR("B")="YES",DIR("?")="Answer YES to print this C&P report or answer NO to exit." W ! D ^DIR K DIR G:Y'=1 ADEX I Y=1 D DEV G ADEX
51 I '$D(ACKD0) D
52 .W !!,"You can print any C&P report at this time. Reports can be printed",!,"for exams requested through the AMIE software. Reports can also be"
53 .W !,"printed for exams NOT requested by AMIE (e.g., the C&P fields were",!,"""forced"" by entering ""^C AND P"" during data input)."
54 I '$D(ACKD0) S DIR(0)="Y",DIR("A")="Print a selected C&P report NOW",DIR("B")="NO",DIR("?")="Answer YES to print any C&P report or answer NO to exit." W ! D ^DIR K DIR I Y=1 D CP^ACKQCP1 I $D(ACKD0) D PULL^ACKQCP1,DEV
55 ;
56ADEX ;
57 K ACK0,ACK2,ACKC,ACKCNT,ACKD0,ACKFLD,ACKI,ACKQHLP,ACKPG,ACKQRAW,ACKST,ACKSFT,ACKSIG,ACKSUPER,ACKTITL,ACKTX,DA,DFN,DIC,DIE,DIRUT,DR,DTOUT,DUOUT,I,VA,VADM,VAERR,X,X1,Y
58 Q
59 ;
60SIG ; Get Electronic Signature
61 ; Enter with ACKMODE=1 to sign off or 2 to adequate an exam.
62 ;
63 N ACKTT
64 S ACKMODE(1)="sign off",ACKMODE(2)="adequate"
65 S (ACKSIG,ACKTITL)="",ACK20=$S($D(^VA(200,DUZ,20)):^(20),1:""),ACK20(2)=$P(ACK20,U,2),ACK20(3)=$P(ACK20,U,3),ACK20(4)=$P(ACK20,U,4)
66 I ACK20(4)="" W !,$C(7),"YOU DON'T HAVE AN ELECTRONIC SIGNATURE CODE!" G NOSIG
67 W !!,"Are you ready to "_ACKMODE(ACKMODE)_" this exam" S %=2 D YN^DICN I '% S ACKQHLP=6 D ^ACKQHLP G SIG
68 G:%'=1 NOSIG S ACKI=0 D GETCODE Q
69 ;
70GETCODE X ^%ZOSF("EOFF") R !,"SIGNATURE CODE: ",X:DTIME S:'$T X=U X ^%ZOSF("EON") I U[X G NOSIG
71 D HASH^XUSHSHP I X'=ACK20(4) W $C(7) S ACKI=ACKI+1 G:ACKI<3 GETCODE W !,"TOO MANY TRIES!" G NOSIG
72 ;
73 ; If they get past here it's good
74 ;
75 W !,"Ok..." S ACKSIG=ACK20(2),ACKTITL=ACK20(3) G SIGEX
76NOSIG K ACKSIG,ACKTITL
77SIGEX K %,%Y,ACK20,ACKI,ACKMODE,Y Q
78 ;
79ADEQWN ;;
80 ;;
81 ;; *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
82 ;; * WARNING! *
83 ;; * Entering your electronic signature to adequate *
84 ;; * this exam will cause all exam results to be *
85 ;; * transferred to the AMIE C&P package and the exam *
86 ;; * will be tagged CLOSED. The results will then *
87 ;; * be available to the regional office. *
88 ;; * Do not proceed unless the exam is complete and *
89 ;; * you are satisfied with the accuracy of the *
90 ;; * information! *
91 ;; *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
92 ;;
93 ;;
94SHOW ;
95 D HOME^%ZIS,SHO1
96 W !! S DIR(0)="SBM^P:Print;C:Continue",DIR("?")="Enter P to print the C&P exam or C to continue with adequation." D ^DIR K DIR Q:Y'="P"
97DEV W !!,"The right margin for this report is 80.",!,"You can queue it to run at a later time.",!
98 K %ZIS,IOP S %ZIS="QM",%ZIS("B")="" D ^%ZIS I POP W !,"NO DEVICE SELECTED OR REPORT PRINTED." Q
99 I $D(IO("Q")) K IO("Q") S ZTRTN="SHO1^ACKQCP",ZTDESC="QUASAR - PRINT C&P EXAM",ZTSAVE("ACK*")="",ZTSAVE("DFN")="",ZTSAVE("VADM(2)")="" D ^%ZTLOAD,^%ZISC Q
100 ;
101SHO1 U IO S ACKPG=0
102 D HDR I '$O(ACKC(0)) W !,"No C&P exam data found." Q
103 S ACKC=0 F S ACKC=$O(ACKC(ACKC)) Q:'ACKC!($D(DUOUT))!($D(DTOUT)) D
104 .I $Y>(IOSL-5) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DTOUT)!($D(DUOUT)) D HDR
105 .W !,ACKC(ACKC)
106 D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
107 Q
108 ;
109HDR ; Print report heading.
110 S ACKPG=ACKPG+1
111 W @IOF,"Printed: "_$$NUMDT^ACKQUTL(DT),?(IOM-8),"Page: ",ACKPG
112 F X="Audiology & Speech Pathology","C&P Exam for "_$P(^DPT(DFN,0),U)_" ("_$P(VADM(2),"^",2)_")" W ! D CNTR^ACKQUTL(X)
113 S X="",$P(X,"-",IOM)="-" W !,X
114 Q
115 ;
116UNLOCK ; Unlocks locked visit record
117 L -^ACK(509850.6,ACKD0)
118 Q
119 ;
Note: See TracBrowser for help on using the repository browser.