ACKQCP ;AUG/JLTP BIR/PTD HCIOFO/BH-QUASAR/C&P Interface ; 06/06/99 11:51
;;3.0;QUASAR;**1,2**;Feb 11, 2000
;Per VHA Directive 10-93-142, this routine SHOULD NOT be modified.
;;DBIA 1473 EN1^DVBCTRN & EN2^DVBCTRN
;
ADEQ ; Adequate a C&P Exam
N ACKDUZ
S ACKDUZ=$$PROVCHK^ACKQASU4(DUZ) S:ACKDUZ="" ACKDUZ=" "
I $O(^ACK(509850.3,ACKDUZ,""))="" W !,"You are not listed in the A&SP STAFF file (#509850.3).",!,"Access denied." G ADEX
S X=$$STACT^ACKQUTL(ACKDUZ) I (X=-2)!(X=-6) W !,"Only clinicians may adequate C&P exams!" G ADEX
I X W !,"The A&SP STAFF file (#509850.3) indicates that you have been inactivated.",!,"Access denied." G ADEX
;
OPTN ; Introduce option.
W @IOF
W !,"This option allows you to adequate C&P exams which currently have open"
W !,"requests in the AMIE software. An exam must be completed and signed off prior"
W !,"to adequation. You can use the Edit an Existing Visit option to review or edit"
W !,"an exam before adequating.",!
;
D ^ACKQCPL G:$D(DIRUT) PRINT
D PULL^ACKQCP1,SHOW
;
F I=1:1 S ACKTX=$P($T(ADEQWN+I),";;",2) Q:ACKTX="" W !,ACKTX
;
S ACKMODE=2 D SIG^ACKQCP I '$D(ACKSIG) D UNLOCK G ADEX
;
N ACKQVD,ACKQQPV,ACKQQPV1 S ACKQQPV1=""
I $$EN1^DVBCTRN(DFN,"AUDIO",ACKSFT)>0 D
. S DIE="^ACK(509850.6,",DA=ACKD0
. S DR="4.19////"_ACKSIG_";4.2////"_DT_";4.25////"_ACKTITL
. D ^DIE K ACKC D PULL^ACKQCP1
;
S ACKQVD=$$GET1^DIQ(509850.6,ACKD0_",",.01,"I")
S ACKQQPV=$$GET1^DIQ(509850.6,ACKD0,6,"I")
I ACKQQPV'="" S ACKQQPV1=$$CONVERT1^ACKQUTL4(ACKQQPV)
I ACKQQPV1'="" S ACKST=$$EN2^DVBCTRN("ACKC","ACKQ",ACKSFT,ACKQQPV1,ACKQVD)
;
I ACKQQPV1="" S ACKST=$$EN2^DVBCTRN("ACKC","ACKQ",ACKSFT,"",ACKQVD)
;
I ACKST>0 D
. N ACKQARR
. S ACKQARR(509850.6,ACKD0_",",.09)="3" D FILE^DIE("","ACKQARR","")
. I $D(^ACK(509850.6,"AWAIT",2,ACKD0)) K ^ACK(509850.6,"AWAIT",2,ACKD0)
. K ACKQARR
;
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
;
W !!,"Final results transferred to AMIE C&P package." D UNLOCK
;
PRINT 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
I '$D(ACKD0) D
.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"
.W !,"printed for exams NOT requested by AMIE (e.g., the C&P fields were",!,"""forced"" by entering ""^C AND P"" during data input)."
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
;
ADEX ;
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
Q
;
SIG ; Get Electronic Signature
; Enter with ACKMODE=1 to sign off or 2 to adequate an exam.
;
N ACKTT
S ACKMODE(1)="sign off",ACKMODE(2)="adequate"
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)
I ACK20(4)="" W !,$C(7),"YOU DON'T HAVE AN ELECTRONIC SIGNATURE CODE!" G NOSIG
W !!,"Are you ready to "_ACKMODE(ACKMODE)_" this exam" S %=2 D YN^DICN I '% S ACKQHLP=6 D ^ACKQHLP G SIG
G:%'=1 NOSIG S ACKI=0 D GETCODE Q
;
GETCODE X ^%ZOSF("EOFF") R !,"SIGNATURE CODE: ",X:DTIME S:'$T X=U X ^%ZOSF("EON") I U[X G NOSIG
D HASH^XUSHSHP I X'=ACK20(4) W $C(7) S ACKI=ACKI+1 G:ACKI<3 GETCODE W !,"TOO MANY TRIES!" G NOSIG
;
; If they get past here it's good
;
W !,"Ok..." S ACKSIG=ACK20(2),ACKTITL=ACK20(3) G SIGEX
NOSIG K ACKSIG,ACKTITL
SIGEX K %,%Y,ACK20,ACKI,ACKMODE,Y Q
;
ADEQWN ;;
;;
;; *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
;; * WARNING! *
;; * Entering your electronic signature to adequate *
;; * this exam will cause all exam results to be *
;; * transferred to the AMIE C&P package and the exam *
;; * will be tagged CLOSED. The results will then *
;; * be available to the regional office. *
;; * Do not proceed unless the exam is complete and *
;; * you are satisfied with the accuracy of the *
;; * information! *
;; *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
;;
;;
SHOW ;
D HOME^%ZIS,SHO1
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"
DEV W !!,"The right margin for this report is 80.",!,"You can queue it to run at a later time.",!
K %ZIS,IOP S %ZIS="QM",%ZIS("B")="" D ^%ZIS I POP W !,"NO DEVICE SELECTED OR REPORT PRINTED." Q
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
;
SHO1 U IO S ACKPG=0
D HDR I '$O(ACKC(0)) W !,"No C&P exam data found." Q
S ACKC=0 F S ACKC=$O(ACKC(ACKC)) Q:'ACKC!($D(DUOUT))!($D(DTOUT)) D
.I $Y>(IOSL-5) D:$E(IOST)="C" PAUSE^ACKQUTL Q:$D(DTOUT)!($D(DUOUT)) D HDR
.W !,ACKC(ACKC)
D ^%ZISC S:$D(ZTQUEUED) ZTREQ="@"
Q
;
HDR ; Print report heading.
S ACKPG=ACKPG+1
W @IOF,"Printed: "_$$NUMDT^ACKQUTL(DT),?(IOM-8),"Page: ",ACKPG
F X="Audiology & Speech Pathology","C&P Exam for "_$P(^DPT(DFN,0),U)_" ("_$P(VADM(2),"^",2)_")" W ! D CNTR^ACKQUTL(X)
S X="",$P(X,"-",IOM)="-" W !,X
Q
;
UNLOCK ; Unlocks locked visit record
L -^ACK(509850.6,ACKD0)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HACKQCP 5790 printed Nov 22, 2024@17:42:03 Page 2
ACKQCP ;AUG/JLTP BIR/PTD HCIOFO/BH-QUASAR/C&P Interface ; 06/06/99 11:51
+1 ;;3.0;QUASAR;**1,2**;Feb 11, 2000
+2 ;Per VHA Directive 10-93-142, this routine SHOULD NOT be modified.
+3 ;;DBIA 1473 EN1^DVBCTRN & EN2^DVBCTRN
+4 ;
ADEQ ; Adequate a C&P Exam
+1 NEW ACKDUZ
+2 SET ACKDUZ=$$PROVCHK^ACKQASU4(DUZ)
if ACKDUZ=""
SET ACKDUZ=" "
+3 IF $ORDER(^ACK(509850.3,ACKDUZ,""))=""
WRITE !,"You are not listed in the A&SP STAFF file (#509850.3).",!,"Access denied."
GOTO ADEX
+4 SET X=$$STACT^ACKQUTL(ACKDUZ)
IF (X=-2)!(X=-6)
WRITE !,"Only clinicians may adequate C&P exams!"
GOTO ADEX
+5 IF X
WRITE !,"The A&SP STAFF file (#509850.3) indicates that you have been inactivated.",!,"Access denied."
GOTO ADEX
+6 ;
OPTN ; Introduce option.
+1 WRITE @IOF
+2 WRITE !,"This option allows you to adequate C&P exams which currently have open"
+3 WRITE !,"requests in the AMIE software. An exam must be completed and signed off prior"
+4 WRITE !,"to adequation. You can use the Edit an Existing Visit option to review or edit"
+5 WRITE !,"an exam before adequating.",!
+6 ;
+7 DO ^ACKQCPL
if $DATA(DIRUT)
GOTO PRINT
+8 DO PULL^ACKQCP1
DO SHOW
+9 ;
+10 FOR I=1:1
SET ACKTX=$PIECE($TEXT(ADEQWN+I),";;",2)
if ACKTX=""
QUIT
WRITE !,ACKTX
+11 ;
+12 SET ACKMODE=2
DO SIG^ACKQCP
IF '$DATA(ACKSIG)
DO UNLOCK
GOTO ADEX
+13 ;
+14 NEW ACKQVD,ACKQQPV,ACKQQPV1
SET ACKQQPV1=""
+15 IF $$EN1^DVBCTRN(DFN,"AUDIO",ACKSFT)>0
Begin DoDot:1
+16 SET DIE="^ACK(509850.6,"
SET DA=ACKD0
+17 SET DR="4.19////"_ACKSIG_";4.2////"_DT_";4.25////"_ACKTITL
+18 DO ^DIE
KILL ACKC
DO PULL^ACKQCP1
End DoDot:1
+19 ;
+20 SET ACKQVD=$$GET1^DIQ(509850.6,ACKD0_",",.01,"I")
+21 SET ACKQQPV=$$GET1^DIQ(509850.6,ACKD0,6,"I")
+22 IF ACKQQPV'=""
SET ACKQQPV1=$$CONVERT1^ACKQUTL4(ACKQQPV)
+23 IF ACKQQPV1'=""
SET ACKST=$$EN2^DVBCTRN("ACKC","ACKQ",ACKSFT,ACKQQPV1,ACKQVD)
+24 ;
+25 IF ACKQQPV1=""
SET ACKST=$$EN2^DVBCTRN("ACKC","ACKQ",ACKSFT,"",ACKQVD)
+26 ;
+27 IF ACKST>0
Begin DoDot:1
+28 NEW ACKQARR
+29 SET ACKQARR(509850.6,ACKD0_",",.09)="3"
DO FILE^DIE("","ACKQARR","")
+30 IF $DATA(^ACK(509850.6,"AWAIT",2,ACKD0))
KILL ^ACK(509850.6,"AWAIT",2,ACKD0)
+31 KILL ACKQARR
End DoDot:1
+32 ;
+33 IF ACKST<0
WRITE !!,$CHAR(7),$PIECE(ACKST,U,2),!,"Results NOT transferred!!"
SET DIE="^ACK(509850.6,"
SET DA=ACKD0
SET DR="4.19///@;4.2///@;4.25///@"
DO ^DIE
KILL DIE
DO UNLOCK
GOTO ADEX
+34 ;
+35 WRITE !!,"Final results transferred to AMIE C&P package."
DO UNLOCK
+36 ;
PRINT IF $DATA(ACKD0)
SET DIR(0)="Y"
SET DIR("A")="Print a file copy NOW"
SET DIR("B")="YES"
SET DIR("?")="Answer YES to print this C&P report or answer NO to exit."
WRITE !
DO ^DIR
KILL DIR
if Y'=1
GOTO ADEX
IF Y=1
DO DEV
GOTO ADEX
+1 IF '$DATA(ACKD0)
Begin DoDot:1
+2 WRITE !!,"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"
+3 WRITE !,"printed for exams NOT requested by AMIE (e.g., the C&P fields were",!,"""forced"" by entering ""^C AND P"" during data input)."
End DoDot:1
+4 IF '$DATA(ACKD0)
SET DIR(0)="Y"
SET DIR("A")="Print a selected C&P report NOW"
SET DIR("B")="NO"
SET DIR("?")="Answer YES to print any C&P report or answer NO to exit."
WRITE !
DO ^DIR
KILL DIR
IF Y=1
DO CP^ACKQCP1
IF $DATA(ACKD0)
DO PULL^ACKQCP1
DO DEV
+5 ;
ADEX ;
+1 KILL 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
+2 QUIT
+3 ;
SIG ; Get Electronic Signature
+1 ; Enter with ACKMODE=1 to sign off or 2 to adequate an exam.
+2 ;
+3 NEW ACKTT
+4 SET ACKMODE(1)="sign off"
SET ACKMODE(2)="adequate"
+5 SET (ACKSIG,ACKTITL)=""
SET ACK20=$SELECT($DATA(^VA(200,DUZ,20)):^(20),1:"")
SET ACK20(2)=$PIECE(ACK20,U,2)
SET ACK20(3)=$PIECE(ACK20,U,3)
SET ACK20(4)=$PIECE(ACK20,U,4)
+6 IF ACK20(4)=""
WRITE !,$CHAR(7),"YOU DON'T HAVE AN ELECTRONIC SIGNATURE CODE!"
GOTO NOSIG
+7 WRITE !!,"Are you ready to "_ACKMODE(ACKMODE)_" this exam"
SET %=2
DO YN^DICN
IF '%
SET ACKQHLP=6
DO ^ACKQHLP
GOTO SIG
+8 if %'=1
GOTO NOSIG
SET ACKI=0
DO GETCODE
QUIT
+9 ;
GETCODE XECUTE ^%ZOSF("EOFF")
READ !,"SIGNATURE CODE: ",X:DTIME
if '$TEST
SET X=U
XECUTE ^%ZOSF("EON")
IF U[X
GOTO NOSIG
+1 DO HASH^XUSHSHP
IF X'=ACK20(4)
WRITE $CHAR(7)
SET ACKI=ACKI+1
if ACKI<3
GOTO GETCODE
WRITE !,"TOO MANY TRIES!"
GOTO NOSIG
+2 ;
+3 ; If they get past here it's good
+4 ;
+5 WRITE !,"Ok..."
SET ACKSIG=ACK20(2)
SET ACKTITL=ACK20(3)
GOTO SIGEX
NOSIG KILL ACKSIG,ACKTITL
SIGEX KILL %,%Y,ACK20,ACKI,ACKMODE,Y
QUIT
+1 ;
ADEQWN ;;
+1 ;;
+2 ;; *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
+3 ;; * WARNING! *
+4 ;; * Entering your electronic signature to adequate *
+5 ;; * this exam will cause all exam results to be *
+6 ;; * transferred to the AMIE C&P package and the exam *
+7 ;; * will be tagged CLOSED. The results will then *
+8 ;; * be available to the regional office. *
+9 ;; * Do not proceed unless the exam is complete and *
+10 ;; * you are satisfied with the accuracy of the *
+11 ;; * information! *
+12 ;; *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
+13 ;;
+14 ;;
SHOW ;
+1 DO HOME^%ZIS
DO SHO1
+2 WRITE !!
SET DIR(0)="SBM^P:Print;C:Continue"
SET DIR("?")="Enter P to print the C&P exam or C to continue with adequation."
DO ^DIR
KILL DIR
if Y'="P"
QUIT
DEV WRITE !!,"The right margin for this report is 80.",!,"You can queue it to run at a later time.",!
+1 KILL %ZIS,IOP
SET %ZIS="QM"
SET %ZIS("B")=""
DO ^%ZIS
IF POP
WRITE !,"NO DEVICE SELECTED OR REPORT PRINTED."
QUIT
+2 IF $DATA(IO("Q"))
KILL IO("Q")
SET ZTRTN="SHO1^ACKQCP"
SET ZTDESC="QUASAR - PRINT C&P EXAM"
SET ZTSAVE("ACK*")=""
SET ZTSAVE("DFN")=""
SET ZTSAVE("VADM(2)")=""
DO ^%ZTLOAD
DO ^%ZISC
QUIT
+3 ;
SHO1 USE IO
SET ACKPG=0
+1 DO HDR
IF '$ORDER(ACKC(0))
WRITE !,"No C&P exam data found."
QUIT
+2 SET ACKC=0
FOR
SET ACKC=$ORDER(ACKC(ACKC))
if 'ACKC!($DATA(DUOUT))!($DATA(DTOUT))
QUIT
Begin DoDot:1
+3 IF $Y>(IOSL-5)
if $EXTRACT(IOST)="C"
DO PAUSE^ACKQUTL
if $DATA(DTOUT)!($DATA(DUOUT))
QUIT
DO HDR
+4 WRITE !,ACKC(ACKC)
End DoDot:1
+5 DO ^%ZISC
if $DATA(ZTQUEUED)
SET ZTREQ="@"
+6 QUIT
+7 ;
HDR ; Print report heading.
+1 SET ACKPG=ACKPG+1
+2 WRITE @IOF,"Printed: "_$$NUMDT^ACKQUTL(DT),?(IOM-8),"Page: ",ACKPG
+3 FOR X="Audiology & Speech Pathology","C&P Exam for "_$PIECE(^DPT(DFN,0),U)_" ("_$PIECE(VADM(2),"^",2)_")"
WRITE !
DO CNTR^ACKQUTL(X)
+4 SET X=""
SET $PIECE(X,"-",IOM)="-"
WRITE !,X
+5 QUIT
+6 ;
UNLOCK ; Unlocks locked visit record
+1 LOCK -^ACK(509850.6,ACKD0)
+2 QUIT
+3 ;
