DVBCIUTL ;ALB/GTS-AMIE INSUFFICIENT RPT UTILITY RTN ; 11/14/94 9:15 AM
;;2.7;AMIE;**13,17,19,149,184,185,192**;Apr 10, 1995;Build 15
;Per VHA Directive 2004-038, this routine should not be modified.
;
;** Version Changes
; 2.7 - New routine (Enhc 15)
;
DETHD ;** AMIE Detailed Report header
N DVBAI,DVBATXT S DVBAI=2
;I DVBADLMTR="," S:DVBAPRTY'["QS" MSGCNT=1 S:$G(DVBAP)="QS" ^TMP("INSUFF",$J,MSGCNT)=$C(13)_$C(13),MSGCNT=MSGCNT+1 D DETHDLIM Q
I DVBADLMTR="," D Q
. S MSGCNT=MSGCNT+1
. S:$G(DVBAP)="QS" ^TMP("INSUFF",$J,MSGCNT)=$C(13)_$C(13),MSGCNT=MSGCNT+1 D DETHDLIM Q
. I MSGCNT=1!(MSGCNT=2) D DETHDLIM Q
S:'$D(DVBAPG1) TVAR(1,0)="0,15,0,1,0^Detailed Insufficient Exam Report"
S:$D(DVBAPG1) TVAR(1,0)="0,15,0,1,1^Detailed Insufficient Exam Report"
S DVBATXT=$$PRHD(DVBAPRTY)
S TVAR(DVBAI,0)="0,"_((63-$L(DVBATXT))\2)_",0,1,0^"_DVBATXT
S DVBAI=DVBAI+1
S TVAR(DVBAI,0)="0,11,0,2,0^For Date Range: "_STRTDT_" to "_LSTDT
D WR^DVBAUTL4("TVAR")
K TVAR
Q
CAPDETHD ;** CAPRI Detailed Report header
N DVBAI,DVBATXT S DVBAI=2
I DVBADLMTR="," D Q
. S MSGCNT=MSGCNT+1
. I MSGCNT=1!(MSGCNT=2) D DETHDLIM Q
S:'$D(DVBAPG1) TVAR(1,0)="0,15,0,1,0^Detailed Insufficient Exam Report"
S:$D(DVBAPG1) TVAR(1,0)="0,15,0,1,1^Detailed Insufficient Exam Report"
S DVBATXT=""
S TVAR(DVBAI,0)="0,"_((63-$L(DVBATXT))\2)_",0,0,0^"_DVBATXT
S DVBAI=DVBAI+1
S TVAR(DVBAI,0)="0,11,0,1,0^For Date Range: "_STRTDT_" to "_LSTDT
D WR^DVBAUTL4("TVAR")
K TVAR
Q
;
DETHDLIM ;Print Report Header in delimited format
S ^TMP("INSUFF",$J,MSGCNT)="Detailed Insufficient Exam Report"_$C(13),MSGCNT=MSGCNT+1
S ^TMP("INSUFF",$J,MSGCNT)="FOR DATE RANGE: "_STRTDT_" TO "_LSTDT_$C(13)_$C(13),MSGCNT=MSGCNT+1
S ^TMP("INSUFF",$J,MSGCNT)="Reason"_DVBADLMTR_"Exam"_DVBADLMTR_"Provider"_DVBADLMTR_"Exam Date"_DVBADLMTR_"Patient Name"_DVBADLMTR_"SSN"_DVBADLMTR
S ^TMP("INSUFF",$J,MSGCNT)=^TMP("INSUFF",$J,MSGCNT)_"Claim #"_DVBADLMTR_"Claim Type"_DVBADLMTR_"Special Consideration(s)"_DVBADLMTR_"Priority of Exam"_DVBADLMTR
S ^TMP("INSUFF",$J,MSGCNT)=^TMP("INSUFF",$J,MSGCNT)_"Cancellation Information"_DVBADLMTR_"Cancellation Reason"_$C(13),MSGCNT=MSGCNT+1
Q
;
;Input : DVBAPRTY - Priority Exam Code (File #396.3 Fld #9)
;Output: Description for Priority Exam Code
PRHD(DVBAPRTY) ;priority exam type header info
N DVBATXT
S DVBATXT=$S((DVBAPRTY["BDD"):"Benefits Delivery at Discharge",1:"X")
S:(DVBATXT="X") DVBATXT=$S((DVBAPRTY["QS"):"Quick Start",1:"X")
S:(DVBATXT="X") DVBATXT=$S((DVBAPRTY["IDES"):"Integrated Disability Evaluation System",1:"X")
S:(DVBATXT="X") DVBATXT=$S((DVBAPRTY["AO"):"Agent Orange",1:"Excludes Exam Priorities: AO,BDD,IDES,QS")
S:(DVBATXT'["Excludes") DVBATXT="Priority of Exam: "_DVBATXT
Q $G(DVBATXT)
;
EXMOUT ;** Output exam information for reason/type
I $Y>(IOSL-9) DO
.I IOST?1"C-".E D TERM^DVBCUTL3
D
.I '$D(GETOUT) DO
..;D DETHD
..D RESOUT
..W !
..D TYPEOUT
..S (DVBARSPT,DVBAXMPT)=""
I '$D(GETOUT) DO
.I '$D(DVBARSPT) DO
..D RESOUT
..S DVBARSPT=""
.I '$D(DVBAXMPT) DO
..W !
..D TYPEOUT
..S DVBAXMPT=""
.S (DVBARQDT,DVBAXDT,DVBAXRS)=""
.S REQDA=$P(^DVB(396.4,XMDA,0),U,2) ;*REQDA of PRIORITY Insuf 2507
.I $D(^DVB(396.4,XMDA,"CAN")) D
..S DVBAXDT=$P(^DVB(396.4,XMDA,"CAN"),U,1),DVBAXRS=$P(^("CAN"),U,3)
..I DVBAXDT S DVBAXDT=$$FMTE^XLFDT(DVBAXDT,"5DZ")
..I DVBAXRS S DVBAXRS=$P(^DVB(396.5,DVBAXRS,0),U,1)
.I +REQDA>0 DO ;*Get REQDA of Orig 2507
..S DFN=$P(^DVB(396.3,REQDA,0),U,1),DVBARQDT=$P(^(0),U,2),DVBARQDT=$$FMTE^XLFDT(DVBARQDT,"5DZ")
..I '$D(^DVB(396.3,REQDA,5)) S REQDA=""
..I +REQDA>0,($D(^DVB(396.3,REQDA,5))) S REQDA=$P(^DVB(396.3,REQDA,5),U,1)
.S DVBAORXM=""
.I +REQDA>0 DO ;*If link to orig 2507
..S DVBAXMTP=$P(^DVB(396.4,XMDA,0),U,3)
..S DVBACMND="F S DVBAORXM=$O(^DVB(396.4,""ARQ"_REQDA_""","_DVBAXMTP_",DVBAORXM)) Q:DVBAORXM="""" Q:$D(^DVB(396.4,""APS"","_DFN_","_DVBAXMTP_",""C"",DVBAORXM))"
..X DVBACMND ;**Return DA of original, insuff exam
.S DVBANAME=$P(^DPT(DFN,0),U,1)
.D DEM^VADPT I $G(VADM(1))'="" S DVBASSN=$S(DVBADLMTR=",":$P($G(VADM(2)),U,2),1:$P($G(VADM(2)),U,1))
.S DVBACNUM="" S:$D(^DPT(DFN,.31)) DVBACNUM=$P(^DPT(DFN,.31),U,3)
.I DVBAORXM'="",($D(^DVB(396.4,DVBAORXM,0))) S DVBAORDT=$P(^DVB(396.4,DVBAORXM,0),U,6)
.I DVBAORXM'="",('$D(^DVB(396.4,DVBAORXM,0))) S (DVBAORDT,DVBADTE)=""
.S:DVBAORXM="" (DVBAORDT,DVBADTE)=""
.S:DVBAORDT="" DVBADTE=""
.I DVBAORDT'="" DO
..S DVBADTWK=$P(DVBAORDT,".",1)
..S DVBADTE=$$FMTE^XLFDT(DVBADTWK,"5DZ")
.S DVBAORPV=$P(^DVB(396.4,XMDA,0),U,12)
.S DVBABIEN=$P(^DVB(396.4,XMDA,0),U,2)
.D CLAIMTYP,SPEC,PRIORITY
.I DVBADLMTR="," D DETDELIM D:DVBAXDT]"" DETITEMS S ^TMP("INSUFF",$J,MSGCNT)=^TMP("INSUFF",$J,MSGCNT)_$C(13),MSGCNT=MSGCNT+1 Q
.S DVBAORP1=$E(DVBAORPV,1,15)
.S DVBANAM1=$E(DVBANAME,1,15)
.W !,DVBAORP1
.W:$L(DVBAORPV)>$L(DVBAORP1) "**" ;**Indicate that Dr.'s Name truncated
.W ?20,DVBADTE,?32,DVBANAM1
.W:$L(DVBANAME)>$L(DVBANAM1) "**" ;**Indicate that Vet's Name truncated
.W ?52,DVBASSN,?66,DVBACNUM
.W !,?2,"Claim Type: "_DVBCTW,!,?2,"Special Consideration(s): "_DVBSCWA,!,?2,"Priority Of Exam: "_DVBPOX
.I DVBAXDT]"" D
..W !,"Exam request of "_DVBARQDT_" to correct insufficiency was cancelled on "_DVBAXDT_"."
..W !,"Reason: "_DVBAXRS_"."
K DVBAA,DVBABIEN,DVBSC,DVBSCC,DVBSCN,DVBSCNS,DVBSCW,DVBSCWA,DVBPOX,DVBPOXID
Q
;
DETDELIM ; Print details of Insufficient Exams
; Reason,Exam,Provider,Exam Date,Patient Name,SSN,Claim #,Claim Type,Special Consideration(s),Priority of Exam
I $D(^TMP("INSUFF",$J,MSGCNT)) D
.S ^TMP("INSUFF",$J,MSGCNT)=^TMP("INSUFF",$J,MSGCNT)_""""_DVBAORPV_""""_DVBADLMTR_DVBADTE_DVBADLMTR_""""_DVBANAME_""""_DVBADLMTR_DVBASSN_DVBADLMTR
.S ^TMP("INSUFF",$J,MSGCNT)=^TMP("INSUFF",$J,MSGCNT)_$C(160)_DVBACNUM_DVBADLMTR_DVBCTW_DVBADLMTR_""""_DVBSCWA_""""_DVBADLMTR_DVBPOX_"" Q
I '$D(^TMP("INSUFF",$J,MSGCNT)) D
.S ^TMP("INSUFF",$J,MSGCNT)=DVBADLMTR_DVBADLMTR_""""_DVBAORPV_""""_DVBADLMTR_DVBADTE_DVBADLMTR_""""_DVBANAME_""""_DVBADLMTR_DVBASSN_DVBADLMTR_$C(160)_DVBACNUM_DVBADLMTR_DVBCTW_DVBADLMTR_""""_DVBSCWA_""""_DVBADLMTR_DVBPOX_""
Q
;
DETITEMS ; Print final exam details
S ^TMP("INSUFF",$J,MSGCNT)=^TMP("INSUFF",$J,MSGCNT)_DVBADLMTR_"Exam request of "_DVBARQDT_" to correct insufficiency was cancelled on "_DVBAXDT_"."
S ^TMP("INSUFF",$J,MSGCNT)=^TMP("INSUFF",$J,MSGCNT)_DVBADLMTR_DVBAXRS_"."
Q
;
RESOUT ;** Output the Reason
I DVBADLMTR="," S ^TMP("INSUFF",$J,MSGCNT)=$P(^DVB(396.94,$P(^DVB(396.4,XMDA,0),U,11),0),U,3)_DVBADLMTR Q
W !!!!!,"Reason: ",$P(^DVB(396.94,$P(^DVB(396.4,XMDA,0),U,11),0),U,3)
Q
;
TYPEOUT ;** Output the Exam
I DVBADLMTR="," D TYPEDLIM Q
W !,"Exam: ",$P(^DVB(396.6,$P(^DVB(396.4,XMDA,0),U,3),0),U,2)
W !,"Provider",?20,"Exam Dt",?32,"Patient Name",?52,"SSN",?66,"Claim #"
Q
;
TYPEDLIM ; ** Output the delimited Exam
I $D(^TMP("INSUFF",$J,MSGCNT)) S ^TMP("INSUFF",$J,MSGCNT)=^TMP("INSUFF",$J,MSGCNT)_""""_$P(^DVB(396.6,$P(^DVB(396.4,XMDA,0),U,3),0),U,2)_""""_DVBADLMTR Q
I '$D(^TMP("INSUFF",$J,MSGCNT)) S ^TMP("INSUFF",$J,MSGCNT)=$P(^DVB(396.94,$P(^DVB(396.4,XMDA,0),U,11),0),U,3)_DVBADLMTR_""""_$P(^DVB(396.6,$P(^DVB(396.4,XMDA,0),U,3),0),U,2)_""""_DVBADLMTR Q
;
RSEL ;** Select Reasons
;** The selection prompt is defaulted to ALL. If the user selects
;** 'All', only reasons for exams entered on requests with a
;** priority of 'Insufficient' will be reported. Not all reasons.
;
W @IOF,!
W !,"Insufficient Reason Selection"
S DVBCYQ=""
N RESANS,DVBAOUT S DVBAOUT="" ;**Pre-read
K Y,DTOUT,DUOUT,DVBATSAV
F Q:(DVBAOUT=1!(DVBCYQ=1)) DO
.W !!," Enter '^' to end Reason Selection"
.W !," 'Return' to select all Insufficient Reasons",!
.K DIC,DTOUT,DUOUT,Y
.W !," Enter Insufficient Reason: ALL//"
.R RESANS:DTIME
.S:$T DVBATSAV=""
.I RESANS=""&($D(DVBATSAV)) S Y=-1 D INREAS^DVBCIUT1
.S:('$D(DVBATSAV)!(RESANS["^")) DVBAOUT="1"
.I DVBAOUT'=1,('$D(Y)) DO
..I RESANS["?" DO
...N LPDA S LPDA=0
...W !,"CHOOSE FROM:"
...F S LPDA=$O(^DVB(396.94,LPDA)) Q:+LPDA'>0 DO
....W !,?3,$P(^DVB(396.94,LPDA,0),U,1)
...W !
..I RESANS'["?" DO
...S DIC="^DVB(396.94,"
...S DIC(0)="EMQ"
...S X=RESANS
...D ^DIC
...D:+Y>0 INREAS^DVBCIUT1
.I RESANS="",($D(Y)&(+Y=-1)) S DVBCYQ=1
K DTOUT,DUOUT,Y,DIC,DVBCYQ,DVBATSAV
Q
;
XMSEL ;** Select Exams
;** The selection prompt is defaulted to ALL. If the user selects
;** 'All', only exams entered on requests with a priority of
;** 'Insufficient' will be reported. Not all exams.
;
W @IOF,!
W !,"AMIE Exam Selection"
S DVBCYQ=""
K Y,DTOUT,DUOUT
F Q:($D(DTOUT)!($D(DUOUT)!(DVBCYQ=1))) DO
.W !!," Enter '^' to end Exam Selection"
.W !," 'Return' to select all AMIE Exams",!
.K DIC,DTOUT,DUOUT
.S DIC="^DVB(396.6,"
.S DIC(0)="AEMQ"
.S DIC("A")=" Enter Exam: ALL//"
.;removed screen for inactive exams
.D ^DIC
.I '$D(DTOUT),('$D(DUOUT)) D EXMTPE^DVBCIUT1
.I $D(Y),(+Y=-1) S DVBCYQ=1
K DTOUT,DUOUT,Y,DIC,DVBCYQ
Q
;
;Input: DVBADIRA - Prompt to display for DIR call
;Ouput: Code selected from set or ^ if user exited selection
EXMPRTY(DVBADIRA) ;** Select Priority of Exam
N DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
S DIR(0)="S^AO:Agent Orange;BDD:Benefits Delivery at Discharge / Quick Start;"
S DIR(0)=DIR(0)_"IDES:Integrated Disability Evaluation System;"
S DIR(0)=DIR(0)_"ALL:All Others"
S DIR("A")=$S($G(DVBADIRA)]"":DVBADIRA,1:"Select Priority of Exam for the Report")
S DIR("B")="All Others"
S DIR("T")=DTIME ;time-out value specified by system
S DIR("?",1)="Select the priority of exam(s) to report on or ALL for the original report,"
S DIR("?")="which excludes the AO, BDD and IDES exam priorities."
D ^DIR
Q Y
CLAIMTYP ;THE CLAIM TYPE OF A 2507 REQUEST
S DVBCTW=""
Q:'$D(^DVB(396.3,DVBABIEN,9,0))
;DVBIEN is the 2507 REQUEST FILE IEN
;DVBCTW is the string /name of the CLAIM TYPE
D GETS^DIQ(396.3,DVBABIEN_",","9.1*","E","MSG","ERR")
S DVBCTW=MSG("396.32","1,"_DVBABIEN_",",".01","E")
Q
SPEC ;SPECIAL CONSIDERATION(S) FOR A 2507 REQUEST
K DVBSCW
S DVBSCWA=""
Q:'$D(^DVB(396.3,DVBABIEN,8))
;DVBABIEN is the 2507 REQUEST FILE IEN
;DVBSC is a the SPECIAL CONSIDERATION entry for the 2507 REQUEST
;DVBSCN is the pointer number to the SPECIAL CONSIDERATION file 396.25
;DVBSCW is the string /name of the SPECIAL CONSIDERATION
S DVBAA=$P(^DVB(396.3,DVBABIEN,8,0),U,4)
S (DVBSC,DVBCNT)=0 F S DVBSC=$O(^DVB(396.3,DVBABIEN,8,DVBSC)) Q:'DVBSC D
.S DVBSCN=$P(^DVB(396.3,DVBABIEN,8,DVBSC,0),U,1)
.S DVBSCW(DVBSC)=$G(^DVB(396.25,DVBSCN,0))
.S DVBCNT=DVBCNT+1
.I (DVBCNT'=DVBAA) S:$D(DVBSCW(DVBSC)) DVBSCW(DVBSC)=DVBSCW(DVBSC)_","
S DVBX="" F S DVBX=$O(DVBSCW(DVBX)) Q:'DVBX S DVBSCWA=DVBSCWA_DVBSCW(DVBX)
Q
PRIORITY ;
S DVBPOX=""
Q:($P(^DVB(396.3,DVBABIEN,0),U,10))=""
S DVBPOXID=$P(^DVB(396.3,DVBABIEN,0),U,10)
S DVBPOX=$$GET1^DIQ(396.3,DVBABIEN,"PRIORITY OF EXAM")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBCIUTL 10996 printed Oct 16, 2024@17:45:26 Page 2
DVBCIUTL ;ALB/GTS-AMIE INSUFFICIENT RPT UTILITY RTN ; 11/14/94 9:15 AM
+1 ;;2.7;AMIE;**13,17,19,149,184,185,192**;Apr 10, 1995;Build 15
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ;** Version Changes
+5 ; 2.7 - New routine (Enhc 15)
+6 ;
DETHD ;** AMIE Detailed Report header
+1 NEW DVBAI,DVBATXT
SET DVBAI=2
+2 ;I DVBADLMTR="," S:DVBAPRTY'["QS" MSGCNT=1 S:$G(DVBAP)="QS" ^TMP("INSUFF",$J,MSGCNT)=$C(13)_$C(13),MSGCNT=MSGCNT+1 D DETHDLIM Q
+3 IF DVBADLMTR=","
Begin DoDot:1
+4 SET MSGCNT=MSGCNT+1
+5 if $GET(DVBAP)="QS"
SET ^TMP("INSUFF",$JOB,MSGCNT)=$CHAR(13)_$CHAR(13)
SET MSGCNT=MSGCNT+1
DO DETHDLIM
QUIT
+6 IF MSGCNT=1!(MSGCNT=2)
DO DETHDLIM
QUIT
End DoDot:1
QUIT
+7 if '$DATA(DVBAPG1)
SET TVAR(1,0)="0,15,0,1,0^Detailed Insufficient Exam Report"
+8 if $DATA(DVBAPG1)
SET TVAR(1,0)="0,15,0,1,1^Detailed Insufficient Exam Report"
+9 SET DVBATXT=$$PRHD(DVBAPRTY)
+10 SET TVAR(DVBAI,0)="0,"_((63-$LENGTH(DVBATXT))\2)_",0,1,0^"_DVBATXT
+11 SET DVBAI=DVBAI+1
+12 SET TVAR(DVBAI,0)="0,11,0,2,0^For Date Range: "_STRTDT_" to "_LSTDT
+13 DO WR^DVBAUTL4("TVAR")
+14 KILL TVAR
+15 QUIT
CAPDETHD ;** CAPRI Detailed Report header
+1 NEW DVBAI,DVBATXT
SET DVBAI=2
+2 IF DVBADLMTR=","
Begin DoDot:1
+3 SET MSGCNT=MSGCNT+1
+4 IF MSGCNT=1!(MSGCNT=2)
DO DETHDLIM
QUIT
End DoDot:1
QUIT
+5 if '$DATA(DVBAPG1)
SET TVAR(1,0)="0,15,0,1,0^Detailed Insufficient Exam Report"
+6 if $DATA(DVBAPG1)
SET TVAR(1,0)="0,15,0,1,1^Detailed Insufficient Exam Report"
+7 SET DVBATXT=""
+8 SET TVAR(DVBAI,0)="0,"_((63-$LENGTH(DVBATXT))\2)_",0,0,0^"_DVBATXT
+9 SET DVBAI=DVBAI+1
+10 SET TVAR(DVBAI,0)="0,11,0,1,0^For Date Range: "_STRTDT_" to "_LSTDT
+11 DO WR^DVBAUTL4("TVAR")
+12 KILL TVAR
+13 QUIT
+14 ;
DETHDLIM ;Print Report Header in delimited format
+1 SET ^TMP("INSUFF",$JOB,MSGCNT)="Detailed Insufficient Exam Report"_$CHAR(13)
SET MSGCNT=MSGCNT+1
+2 SET ^TMP("INSUFF",$JOB,MSGCNT)="FOR DATE RANGE: "_STRTDT_" TO "_LSTDT_$CHAR(13)_$CHAR(13)
SET MSGCNT=MSGCNT+1
+3 SET ^TMP("INSUFF",$JOB,MSGCNT)="Reason"_DVBADLMTR_"Exam"_DVBADLMTR_"Provider"_DVBADLMTR_"Exam Date"_DVBADLMTR_"Patient Name"_DVBADLMTR_"SSN"_DVBADLMTR
+4 SET ^TMP("INSUFF",$JOB,MSGCNT)=^TMP("INSUFF",$JOB,MSGCNT)_"Claim #"_DVBADLMTR_"Claim Type"_DVBADLMTR_"Special Consideration(s)"_DVBADLMTR_"Priority of Exam"_DVBADLMTR
+5 SET ^TMP("INSUFF",$JOB,MSGCNT)=^TMP("INSUFF",$JOB,MSGCNT)_"Cancellation Information"_DVBADLMTR_"Cancellation Reason"_$CHAR(13)
SET MSGCNT=MSGCNT+1
+6 QUIT
+7 ;
+8 ;Input : DVBAPRTY - Priority Exam Code (File #396.3 Fld #9)
+9 ;Output: Description for Priority Exam Code
PRHD(DVBAPRTY) ;priority exam type header info
+1 NEW DVBATXT
+2 SET DVBATXT=$SELECT((DVBAPRTY["BDD"):"Benefits Delivery at Discharge",1:"X")
+3 if (DVBATXT="X")
SET DVBATXT=$SELECT((DVBAPRTY["QS"):"Quick Start",1:"X")
+4 if (DVBATXT="X")
SET DVBATXT=$SELECT((DVBAPRTY["IDES"):"Integrated Disability Evaluation System",1:"X")
+5 if (DVBATXT="X")
SET DVBATXT=$SELECT((DVBAPRTY["AO"):"Agent Orange",1:"Excludes Exam Priorities: AO,BDD,IDES,QS")
+6 if (DVBATXT'["Excludes")
SET DVBATXT="Priority of Exam: "_DVBATXT
+7 QUIT $GET(DVBATXT)
+8 ;
EXMOUT ;** Output exam information for reason/type
+1 IF $Y>(IOSL-9)
Begin DoDot:1
+2 IF IOST?1"C-".E
DO TERM^DVBCUTL3
End DoDot:1
+3 Begin DoDot:1
+4 IF '$DATA(GETOUT)
Begin DoDot:2
+5 ;D DETHD
+6 DO RESOUT
+7 WRITE !
+8 DO TYPEOUT
+9 SET (DVBARSPT,DVBAXMPT)=""
End DoDot:2
End DoDot:1
+10 IF '$DATA(GETOUT)
Begin DoDot:1
+11 IF '$DATA(DVBARSPT)
Begin DoDot:2
+12 DO RESOUT
+13 SET DVBARSPT=""
End DoDot:2
+14 IF '$DATA(DVBAXMPT)
Begin DoDot:2
+15 WRITE !
+16 DO TYPEOUT
+17 SET DVBAXMPT=""
End DoDot:2
+18 SET (DVBARQDT,DVBAXDT,DVBAXRS)=""
+19 ;*REQDA of PRIORITY Insuf 2507
SET REQDA=$PIECE(^DVB(396.4,XMDA,0),U,2)
+20 IF $DATA(^DVB(396.4,XMDA,"CAN"))
Begin DoDot:2
+21 SET DVBAXDT=$PIECE(^DVB(396.4,XMDA,"CAN"),U,1)
SET DVBAXRS=$PIECE(^("CAN"),U,3)
+22 IF DVBAXDT
SET DVBAXDT=$$FMTE^XLFDT(DVBAXDT,"5DZ")
+23 IF DVBAXRS
SET DVBAXRS=$PIECE(^DVB(396.5,DVBAXRS,0),U,1)
End DoDot:2
+24 ;*Get REQDA of Orig 2507
IF +REQDA>0
Begin DoDot:2
+25 SET DFN=$PIECE(^DVB(396.3,REQDA,0),U,1)
SET DVBARQDT=$PIECE(^(0),U,2)
SET DVBARQDT=$$FMTE^XLFDT(DVBARQDT,"5DZ")
+26 IF '$DATA(^DVB(396.3,REQDA,5))
SET REQDA=""
+27 IF +REQDA>0
IF ($DATA(^DVB(396.3,REQDA,5)))
SET REQDA=$PIECE(^DVB(396.3,REQDA,5),U,1)
End DoDot:2
+28 SET DVBAORXM=""
+29 ;*If link to orig 2507
IF +REQDA>0
Begin DoDot:2
+30 SET DVBAXMTP=$PIECE(^DVB(396.4,XMDA,0),U,3)
+31 SET DVBACMND="F S DVBAORXM=$O(^DVB(396.4,""ARQ"_REQDA_""","_DVBAXMTP_",DVBAORXM)) Q:DVBAORXM="""" Q:$D(^DVB(396.4,""APS"","_DFN_","_DVBAXMTP_",""C"",DVBAORXM))"
+32 ;**Return DA of original, insuff exam
XECUTE DVBACMND
End DoDot:2
+33 SET DVBANAME=$PIECE(^DPT(DFN,0),U,1)
+34 DO DEM^VADPT
IF $GET(VADM(1))'=""
SET DVBASSN=$SELECT(DVBADLMTR=",":$PIECE($GET(VADM(2)),U,2),1:$PIECE($GET(VADM(2)),U,1))
+35 SET DVBACNUM=""
if $DATA(^DPT(DFN,.31))
SET DVBACNUM=$PIECE(^DPT(DFN,.31),U,3)
+36 IF DVBAORXM'=""
IF ($DATA(^DVB(396.4,DVBAORXM,0)))
SET DVBAORDT=$PIECE(^DVB(396.4,DVBAORXM,0),U,6)
+37 IF DVBAORXM'=""
IF ('$DATA(^DVB(396.4,DVBAORXM,0)))
SET (DVBAORDT,DVBADTE)=""
+38 if DVBAORXM=""
SET (DVBAORDT,DVBADTE)=""
+39 if DVBAORDT=""
SET DVBADTE=""
+40 IF DVBAORDT'=""
Begin DoDot:2
+41 SET DVBADTWK=$PIECE(DVBAORDT,".",1)
+42 SET DVBADTE=$$FMTE^XLFDT(DVBADTWK,"5DZ")
End DoDot:2
+43 SET DVBAORPV=$PIECE(^DVB(396.4,XMDA,0),U,12)
+44 SET DVBABIEN=$PIECE(^DVB(396.4,XMDA,0),U,2)
+45 DO CLAIMTYP
DO SPEC
DO PRIORITY
+46 IF DVBADLMTR=","
DO DETDELIM
if DVBAXDT]""
DO DETITEMS
SET ^TMP("INSUFF",$JOB,MSGCNT)=^TMP("INSUFF",$JOB,MSGCNT)_$CHAR(13)
SET MSGCNT=MSGCNT+1
QUIT
+47 SET DVBAORP1=$EXTRACT(DVBAORPV,1,15)
+48 SET DVBANAM1=$EXTRACT(DVBANAME,1,15)
+49 WRITE !,DVBAORP1
+50 ;**Indicate that Dr.'s Name truncated
if $LENGTH(DVBAORPV)>$LENGTH(DVBAORP1)
WRITE "**"
+51 WRITE ?20,DVBADTE,?32,DVBANAM1
+52 ;**Indicate that Vet's Name truncated
if $LENGTH(DVBANAME)>$LENGTH(DVBANAM1)
WRITE "**"
+53 WRITE ?52,DVBASSN,?66,DVBACNUM
+54 WRITE !,?2,"Claim Type: "_DVBCTW,!,?2,"Special Consideration(s): "_DVBSCWA,!,?2,"Priority Of Exam: "_DVBPOX
+55 IF DVBAXDT]""
Begin DoDot:2
+56 WRITE !,"Exam request of "_DVBARQDT_" to correct insufficiency was cancelled on "_DVBAXDT_"."
+57 WRITE !,"Reason: "_DVBAXRS_"."
End DoDot:2
End DoDot:1
+58 KILL DVBAA,DVBABIEN,DVBSC,DVBSCC,DVBSCN,DVBSCNS,DVBSCW,DVBSCWA,DVBPOX,DVBPOXID
+59 QUIT
+60 ;
DETDELIM ; Print details of Insufficient Exams
+1 ; Reason,Exam,Provider,Exam Date,Patient Name,SSN,Claim #,Claim Type,Special Consideration(s),Priority of Exam
+2 IF $DATA(^TMP("INSUFF",$JOB,MSGCNT))
Begin DoDot:1
+3 SET ^TMP("INSUFF",$JOB,MSGCNT)=^TMP("INSUFF",$JOB,MSGCNT)_""""_DVBAORPV_""""_DVBADLMTR_DVBADTE_DVBADLMTR_""""_DVBANAME_""""_DVBADLMTR_DVBASSN_DVBADLMTR
+4 SET ^TMP("INSUFF",$JOB,MSGCNT)=^TMP("INSUFF",$JOB,MSGCNT)_$CHAR(160)_DVBACNUM_DVBADLMTR_DVBCTW_DVBADLMTR_""""_DVBSCWA_""""_DVBADLMTR_DVBPOX_""
QUIT
End DoDot:1
+5 IF '$DATA(^TMP("INSUFF",$JOB,MSGCNT))
Begin DoDot:1
+6 SET ^TMP("INSUFF",$JOB,MSGCNT)=DVBADLMTR_DVBADLMTR_""""_DVBAORPV_""""_DVBADLMTR_DVBADTE_DVBADLMTR_""""_DVBANAME_""""_DVBADLMTR_DVBASSN_DVBADLMTR_$CHAR(160)_DVBACNUM_DVBADLMTR_DVBCTW_DVBADLMTR_""""_DVBSCWA_""""_DVBADLMTR_DVBPOX_""
End DoDot:1
+7 QUIT
+8 ;
DETITEMS ; Print final exam details
+1 SET ^TMP("INSUFF",$JOB,MSGCNT)=^TMP("INSUFF",$JOB,MSGCNT)_DVBADLMTR_"Exam request of "_DVBARQDT_" to correct insufficiency was cancelled on "_DVBAXDT_"."
+2 SET ^TMP("INSUFF",$JOB,MSGCNT)=^TMP("INSUFF",$JOB,MSGCNT)_DVBADLMTR_DVBAXRS_"."
+3 QUIT
+4 ;
RESOUT ;** Output the Reason
+1 IF DVBADLMTR=","
SET ^TMP("INSUFF",$JOB,MSGCNT)=$PIECE(^DVB(396.94,$PIECE(^DVB(396.4,XMDA,0),U,11),0),U,3)_DVBADLMTR
QUIT
+2 WRITE !!!!!,"Reason: ",$PIECE(^DVB(396.94,$PIECE(^DVB(396.4,XMDA,0),U,11),0),U,3)
+3 QUIT
+4 ;
TYPEOUT ;** Output the Exam
+1 IF DVBADLMTR=","
DO TYPEDLIM
QUIT
+2 WRITE !,"Exam: ",$PIECE(^DVB(396.6,$PIECE(^DVB(396.4,XMDA,0),U,3),0),U,2)
+3 WRITE !,"Provider",?20,"Exam Dt",?32,"Patient Name",?52,"SSN",?66,"Claim #"
+4 QUIT
+5 ;
TYPEDLIM ; ** Output the delimited Exam
+1 IF $DATA(^TMP("INSUFF",$JOB,MSGCNT))
SET ^TMP("INSUFF",$JOB,MSGCNT)=^TMP("INSUFF",$JOB,MSGCNT)_""""_$PIECE(^DVB(396.6,$PIECE(^DVB(396.4,XMDA,0),U,3),0),U,2)_""""_DVBADLMTR
QUIT
+2 IF '$DATA(^TMP("INSUFF",$JOB,MSGCNT))
SET ^TMP("INSUFF",$JOB,MSGCNT)=$PIECE(^DVB(396.94,$PIECE(^DVB(396.4,XMDA,0),U,11),0),U,3)_DVBADLMTR_""""_$PIECE(^DVB(396.6,$PIECE(^DVB(396.4,XMDA,0),U,3),0),U,2)_""""_DVBADLMTR
QUIT
+3 ;
RSEL ;** Select Reasons
+1 ;** The selection prompt is defaulted to ALL. If the user selects
+2 ;** 'All', only reasons for exams entered on requests with a
+3 ;** priority of 'Insufficient' will be reported. Not all reasons.
+4 ;
+5 WRITE @IOF,!
+6 WRITE !,"Insufficient Reason Selection"
+7 SET DVBCYQ=""
+8 ;**Pre-read
NEW RESANS,DVBAOUT
SET DVBAOUT=""
+9 KILL Y,DTOUT,DUOUT,DVBATSAV
+10 FOR
if (DVBAOUT=1!(DVBCYQ=1))
QUIT
Begin DoDot:1
+11 WRITE !!," Enter '^' to end Reason Selection"
+12 WRITE !," 'Return' to select all Insufficient Reasons",!
+13 KILL DIC,DTOUT,DUOUT,Y
+14 WRITE !," Enter Insufficient Reason: ALL//"
+15 READ RESANS:DTIME
+16 if $TEST
SET DVBATSAV=""
+17 IF RESANS=""&($DATA(DVBATSAV))
SET Y=-1
DO INREAS^DVBCIUT1
+18 if ('$DATA(DVBATSAV)!(RESANS["^"))
SET DVBAOUT="1"
+19 IF DVBAOUT'=1
IF ('$DATA(Y))
Begin DoDot:2
+20 IF RESANS["?"
Begin DoDot:3
+21 NEW LPDA
SET LPDA=0
+22 WRITE !,"CHOOSE FROM:"
+23 FOR
SET LPDA=$ORDER(^DVB(396.94,LPDA))
if +LPDA'>0
QUIT
Begin DoDot:4
+24 WRITE !,?3,$PIECE(^DVB(396.94,LPDA,0),U,1)
End DoDot:4
+25 WRITE !
End DoDot:3
+26 IF RESANS'["?"
Begin DoDot:3
+27 SET DIC="^DVB(396.94,"
+28 SET DIC(0)="EMQ"
+29 SET X=RESANS
+30 DO ^DIC
+31 if +Y>0
DO INREAS^DVBCIUT1
End DoDot:3
End DoDot:2
+32 IF RESANS=""
IF ($DATA(Y)&(+Y=-1))
SET DVBCYQ=1
End DoDot:1
+33 KILL DTOUT,DUOUT,Y,DIC,DVBCYQ,DVBATSAV
+34 QUIT
+35 ;
XMSEL ;** Select Exams
+1 ;** The selection prompt is defaulted to ALL. If the user selects
+2 ;** 'All', only exams entered on requests with a priority of
+3 ;** 'Insufficient' will be reported. Not all exams.
+4 ;
+5 WRITE @IOF,!
+6 WRITE !,"AMIE Exam Selection"
+7 SET DVBCYQ=""
+8 KILL Y,DTOUT,DUOUT
+9 FOR
if ($DATA(DTOUT)!($DATA(DUOUT)!(DVBCYQ=1)))
QUIT
Begin DoDot:1
+10 WRITE !!," Enter '^' to end Exam Selection"
+11 WRITE !," 'Return' to select all AMIE Exams",!
+12 KILL DIC,DTOUT,DUOUT
+13 SET DIC="^DVB(396.6,"
+14 SET DIC(0)="AEMQ"
+15 SET DIC("A")=" Enter Exam: ALL//"
+16 ;removed screen for inactive exams
+17 DO ^DIC
+18 IF '$DATA(DTOUT)
IF ('$DATA(DUOUT))
DO EXMTPE^DVBCIUT1
+19 IF $DATA(Y)
IF (+Y=-1)
SET DVBCYQ=1
End DoDot:1
+20 KILL DTOUT,DUOUT,Y,DIC,DVBCYQ
+21 QUIT
+22 ;
+23 ;Input: DVBADIRA - Prompt to display for DIR call
+24 ;Ouput: Code selected from set or ^ if user exited selection
EXMPRTY(DVBADIRA) ;** Select Priority of Exam
+1 NEW DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
+2 SET DIR(0)="S^AO:Agent Orange;BDD:Benefits Delivery at Discharge / Quick Start;"
+3 SET DIR(0)=DIR(0)_"IDES:Integrated Disability Evaluation System;"
+4 SET DIR(0)=DIR(0)_"ALL:All Others"
+5 SET DIR("A")=$SELECT($GET(DVBADIRA)]"":DVBADIRA,1:"Select Priority of Exam for the Report")
+6 SET DIR("B")="All Others"
+7 ;time-out value specified by system
SET DIR("T")=DTIME
+8 SET DIR("?",1)="Select the priority of exam(s) to report on or ALL for the original report,"
+9 SET DIR("?")="which excludes the AO, BDD and IDES exam priorities."
+10 DO ^DIR
+11 QUIT Y
CLAIMTYP ;THE CLAIM TYPE OF A 2507 REQUEST
+1 SET DVBCTW=""
+2 if '$DATA(^DVB(396.3,DVBABIEN,9,0))
QUIT
+3 ;DVBIEN is the 2507 REQUEST FILE IEN
+4 ;DVBCTW is the string /name of the CLAIM TYPE
+5 DO GETS^DIQ(396.3,DVBABIEN_",","9.1*","E","MSG","ERR")
+6 SET DVBCTW=MSG("396.32","1,"_DVBABIEN_",",".01","E")
+7 QUIT
SPEC ;SPECIAL CONSIDERATION(S) FOR A 2507 REQUEST
+1 KILL DVBSCW
+2 SET DVBSCWA=""
+3 if '$DATA(^DVB(396.3,DVBABIEN,8))
QUIT
+4 ;DVBABIEN is the 2507 REQUEST FILE IEN
+5 ;DVBSC is a the SPECIAL CONSIDERATION entry for the 2507 REQUEST
+6 ;DVBSCN is the pointer number to the SPECIAL CONSIDERATION file 396.25
+7 ;DVBSCW is the string /name of the SPECIAL CONSIDERATION
+8 SET DVBAA=$PIECE(^DVB(396.3,DVBABIEN,8,0),U,4)
+9 SET (DVBSC,DVBCNT)=0
FOR
SET DVBSC=$ORDER(^DVB(396.3,DVBABIEN,8,DVBSC))
if 'DVBSC
QUIT
Begin DoDot:1
+10 SET DVBSCN=$PIECE(^DVB(396.3,DVBABIEN,8,DVBSC,0),U,1)
+11 SET DVBSCW(DVBSC)=$GET(^DVB(396.25,DVBSCN,0))
+12 SET DVBCNT=DVBCNT+1
+13 IF (DVBCNT'=DVBAA)
if $DATA(DVBSCW(DVBSC))
SET DVBSCW(DVBSC)=DVBSCW(DVBSC)_","
End DoDot:1
+14 SET DVBX=""
FOR
SET DVBX=$ORDER(DVBSCW(DVBX))
if 'DVBX
QUIT
SET DVBSCWA=DVBSCWA_DVBSCW(DVBX)
+15 QUIT
PRIORITY ;
+1 SET DVBPOX=""
+2 if ($PIECE(^DVB(396.3,DVBABIEN,0),U,10))=""
QUIT
+3 SET DVBPOXID=$PIECE(^DVB(396.3,DVBABIEN,0),U,10)
+4 SET DVBPOX=$$GET1^DIQ(396.3,DVBABIEN,"PRIORITY OF EXAM")
+5 QUIT
