DVBAB6 ;ALB/DJS - CAPRI PENDING 2507 REQUEST REPORT ; 9/8/21 3:59pm
;;2.7;AMIE;**35,90,108,168,185,190,192,193,227,241**;Apr 10, 1995;Build 4
;Per VHA Directive 2004-038, this routine should not be modified.
;
STRT(MSG,DVBCSORT,RSTAT,ERDAYS,OLDAYS,ADIVNUM,ELTYP,DVBADLMTR,ROFILTER) ;
; MSG=DATA Passed back from RPC to GUI;(.MSG,"A","NR",1,1,7613,"W",0,0)
;DVBCSORT=Sort by("A"GE,"S"TATUS,"V"ETERAN NAME,"R"OUTING LOCATION)
;RSTAT= Routing Status("N"ew,"P"ending","T"ranscribed,"NR"New Re-Routed,"RP"Re-routed pending acceptance,"RA"Re-routed acceptance accepted --
; routing status continued - "RR"Re-routed rejected,"RS"RE-routed pending at to site,'A'll statuses)
;ERDAYS= Earliest age if SORTBY is "A"("1" earliest, "7" latest)
;OLDAYS = OLDEST AGE IF SORTBY IS "A"("1"=earliest, "7" oldest)
;ADIVNUM=ROUTING LOCATION -DIVISION IEN
;ELTYP= REPORT TYPE("W"ORK DAYS, "C"ALENDAR DAYS)
;DVBADLMTR= DELIMITER("0"= PLAIN TEXT, "1"=COMMA DELIMITED
;ROFILTER = MODE ("0"=LOCAL MODE, "1"=REMOTE MODE) SDAT,EDAT,RSTAT,DELIM,YNODT
I ADIVNUM'="" S X=$O(^DG(40.8,"C",ADIVNUM,"")) S:X]"" ADIVNUM=X
S DVBADLMTR=$S(DVBADLMTR=1:",",1:0),ROFILTER=$S($G(ROFILTER)'=0:ROFILTER,1:0)
SETUP K ^TMP($J),^TMP("CAPRI")
S DVBCDT(0)=$$FMTE^XLFDT(DT,"5DZ"),PG=1,DVBCCNT=0,DONE="NO",MSGCNT=1,TRNSFIN=""
S DVBCHDR="Sorted by "_$S(DVBCSORT="V":"VETERAN NAME",DVBCSORT="R":"Routing location",DVBCSORT="S":"Status",DVBCSORT="A":"Age of request",1:"Unknown")
HEAD S HEAD="Pending 2507 Requests for "_$S($D(^DVB(396.1,1,0)):$P(^(0),U,1),1:"Unknown site"),PROCDT="Processed on: "_DVBCDT(0),NODATA=0
I $G(DVBADLMTR)'="," D HEADRND G DATA
I $G(DVBADLMTR)="," D HEADRD G DATA
Q
HEADRND ; Print non-delimited output header
;
S ^TMP("CAPRI",MSGCNT)=HEAD_"^",MSGCNT=MSGCNT+1
S ^TMP("CAPRI",MSGCNT)=PROCDT_"^",MSGCNT=MSGCNT+1
S ^TMP("CAPRI",MSGCNT)="^",MSGCNT=MSGCNT+1
S $P(^TMP("CAPRI",MSGCNT),"=",75)="=^",MSGCNT=MSGCNT+1
S ^TMP("CAPRI",MSGCNT)="^",MSGCNT=MSGCNT+1
S ^TMP("CAPRI",MSGCNT)="",MSGCNT=MSGCNT+1
Q
HEADRD ; Print delimited output header
;
S ^TMP("CAPRI",MSGCNT)=HEAD_$C(13),MSGCNT=MSGCNT+1,^TMP("CAPRI",MSGCNT)=PROCDT_$C(13),MSGCNT=MSGCNT+1
S ^TMP("CAPRI",MSGCNT)=$S($G(ROFILTER)'=0:"RO #"_DVBADLMTR,1:"")_"Division"_DVBADLMTR_"Status"_DVBADLMTR_"Veteran Name"_DVBADLMTR_"SSN"_DVBADLMTR_"Claim No."_DVBADLMTR_"Request Date"_DVBADLMTR
S ^TMP("CAPRI",MSGCNT)=^TMP("CAPRI",MSGCNT)_"Elapsed Days"_DVBADLMTR_"Transferred in from"_DVBADLMTR_"Requested by Name"_DVBADLMTR_"Requested by Division"_DVBADLMTR_"Exams Requested"_DVBADLMTR_"Exam Status"_DVBADLMTR
S ^TMP("CAPRI",MSGCNT)=^TMP("CAPRI",MSGCNT)_"Cell Phone"_DVBADLMTR_"Email Address"_DVBADLMTR_"Claim Type"_DVBADLMTR_"Special Consideration(s)"_DVBADLMTR_"ReRouted From"_DVBADLMTR_"ReRouted to"_$C(13)
S MSGCNT=MSGCNT+1
Q
;
DATA ; Sort data records
;
S DFN="" F S DFN=$O(^DVB(396.3,"B",DFN)) Q:DFN="" F REQDA=0:0 S REQDA=$O(^DVB(396.3,"B",DFN,REQDA)) Q:REQDA="" D SORT^DVBAB5
N EXAMRECRD
;I DVBCSORT="V" S PNAM="" F S PNAM=$O(^TMP($J,PNAM)) Q:PNAM="" F DFN=0:0 S DFN=$O(^TMP($J,PNAM,DFN)) Q:'DFN F DA(1)=0:0 S DA(1)=$O(^TMP($J,PNAM,DFN,DA(1))) Q:'DA(1) D PRINT I $D(OUT) S DA(1)=999999999,PNAM="ZZZ",DONE="YES" Q
I DVBCSORT="V" S PNAM="" F S PNAM=$O(^TMP($J,PNAM)) Q:PNAM="" F DFN=0:0 S DFN=$O(^TMP($J,PNAM,DFN)) Q:'DFN F DA(1)=0:0 S DA(1)=$O(^TMP($J,PNAM,DFN,DA(1))) Q:'DA(1) D PRINT
I DVBCSORT="R"!(DVBCSORT="A")!(DVBCSORT="S") D
. S JX="" F S JX=$O(^TMP($J,JX)) Q:JX="" D
.. S PNAM="" F S PNAM=$O(^TMP($J,JX,PNAM)) Q:PNAM="" D
... F DFN=0:0 S DFN=$O(^TMP($J,JX,PNAM,DFN)) Q:'DFN D NXT
I DVBCCNT>0 S ^TMP("CAPRI",MSGCNT)="Total pending: "_DVBCCNT,DONE="YES"
;
EXIT I NODATA=0 S ^TMP("CAPRI",MSGCNT)="No pending request found for select parameters.",MSG=$NA(^TMP("CAPRI"))
I DONE="YES" S MSG=$NA(^TMP("CAPRI"))
K ^TMP($J),ADIV,CNUM,NODATA,STATUS,TST,TSTA1,STSAT,PG,PRTNM,RDATE,RDATE1,REQDA,SSN,RONAME,JX,TRNSFIN,PROCDT,REQSTR,MSGCNT,TSTAT
K DA,DFN,DONE,DVBCCNT,DVBCDT,DVBCHDR,X,XX,ZS,ZZZ,HEAD,HEAD2,OUT,OWNDOM,EDAYS,PNAM,DVBADLMTR,EXAMRECRD,ROFILTER,RONUM,VADM
K DVBAA,DVBCELL,DVBCNT,DVBCTW,DVBEMA,DVBSC,DVBSCN,DVBSCNS,DVBSCW,DVBSCWA,DVBX
Q
;
PRINT ; print 2507 request data
;
S ADIV=$S($D(^DVB(396.3,DA(1),1)):$P(^(1),U,4),1:"") Q:ADIV'=ADIVNUM&(DVBCSORT="R") I ADIV]"" S ADIV=$S($D(^DG(40.8,+ADIV,0)):$P(^(0),U,1),1:"Unknown Division")
S RDATE1=$P(^DVB(396.3,DA(1),0),U,2),RDATE=$P(^(0),U,5)
S SSN=$P($G(^DPT(DFN,0)),U,9) S:SSN="" SSN="Unknown"
S DVBCELL=$P($G(^DPT(DFN,.13)),U,4)
S DVBEMA=$P($G(^DPT(DFN,.13)),U,3)
S CNUM=$P($G(^DPT(DFN,.31)),U,3) S:CNUM="" CNUM="Unknown"
S OWNDOM=$P(^DVB(396.3,DA(1),0),U,22) I OWNDOM]"" S TRNSFIN=$S($D(^DIC(4.2,+OWNDOM,0)):$P(^(0),U,1),1:"Unknown Site") I $G(DVBADLMTR)=0 S ^TMP("CAPRI",MSGCNT)="Transferred in from "_TRNSFIN_"^",MSGCNT=MSGCNT+1
D ELAPSED^DVBAB5
;AJF;Request Status conversion Reports ;
S STATUS="Unknown",XX=$$RSTAT^DVBCUTL8($P(^DVB(396.3,DA(1),0),U,18))
S STATUS=$$EXTERNAL^DILFD(396.3,17,,$P(^DVB(396.3,DA(1),0),U,18))
;S STATUS=$S(XX="N":"New",XX="P":"Pending, reported",XX="S":"Pending, scheduled",XX="R":"Released to RO, not printed",1:"")
;I STATUS="",$D(XX) S STATUS=$S(XX="C":"Completed, printed by RO",XX="X":"Cancelled by RO",XX="T":"Transcribed",XX="NT":"New,Transferred in",XX="CT":"Completed, Transferred out",1:"Unknown")
I $G(DVBADLMTR)="," D PRINTD,ITEMS Q
S ^TMP("CAPRI",MSGCNT)="Division: "_ADIV_"^",MSGCNT=MSGCNT+1
S ^TMP("CAPRI",MSGCNT)="Status: "_STATUS_"^",MSGCNT=MSGCNT+1
S ^TMP("CAPRI",MSGCNT)=PNAM_" ^",MSGCNT=MSGCNT+1
S ^TMP("CAPRI",MSGCNT)="SSN: "_SSN_"^",MSGCNT=MSGCNT+1
S ^TMP("CAPRI",MSGCNT)="Cell no.: "_DVBCELL_"^",MSGCNT=MSGCNT+1
S ^TMP("CAPRI",MSGCNT)="Email: "_DVBEMA_"^",MSGCNT=MSGCNT+1
S ^TMP("CAPRI",MSGCNT)="Claim no: "_CNUM_"^",MSGCNT=MSGCNT+1
S ^TMP("CAPRI",MSGCNT)="Request Date: "_$$FMTE^XLFDT(RDATE1,"5DZ")_"^",MSGCNT=MSGCNT+1
S ^TMP("CAPRI",MSGCNT)="Elapsed days: "_EDAYS_"^",MSGCNT=MSGCNT+1
S X=$S($D(^DVB(396.3,DA(1),4)):^(4),1:"")
D CLAIMTYP,SPEC,REROUTE
S ^TMP("CAPRI",MSGCNT)="ReRouted From: "_DVBRRF_"^",MSGCNT=MSGCNT+1
S ^TMP("CAPRI",MSGCNT)="ReRouted To: "_DVBRRT_"^",MSGCNT=MSGCNT+1
S ^TMP("CAPRI",MSGCNT)="Claim Type: "_DVBCTW_"^",MSGCNT=MSGCNT+1
S ^TMP("CAPRI",MSGCNT)="Special Consideration(s): "_DVBSCWA_"^",MSGCNT=MSGCNT+1
S ^TMP("CAPRI",MSGCNT)="^",MSGCNT=MSGCNT+1
S ^TMP("CAPRI",MSGCNT)="Exams requested:"_"^",MSGCNT=MSGCNT+1
;
ITEMS S NODATA=1,REQSTR=+$P(^DVB(396.3,DA(1),0),U,4)
S ZZZ="Requested by: "_$S($D(^VA(200,+REQSTR,0)):$P(^(0),U,1),1:" (Not specified) ")_" at "
S RONAME=$P(^DVB(396.3,DA(1),0),U,3),RONAME=$S(RONAME]"":$P(^DIC(4,+RONAME,0),U,1),1:"")
I $G(DVBADLMTR)'="," D ITEMSND Q
I $G(DVBADLMTR)="," D ITEMSD Q
ITEMSND D TST S ^TMP("CAPRI",MSGCNT)="^"_ZZZ_$S(RONAME]"":RONAME,1:" (Not specified) ")_"^",MSGCNT=MSGCNT+1
S ^TMP("CAPRI",MSGCNT)="^",MSGCNT=MSGCNT+1
S $P(^TMP("CAPRI",MSGCNT),"-",75)="-^",MSGCNT=MSGCNT+1
S DVBCCNT=DVBCCNT+1
Q
ITEMSD S ZZZ=$S($D(^VA(200,+REQSTR,0)):$P(^(0),U,1),1:" (Not specified) ")
S EXAMRECRD=EXAMRECRD_""""_ZZZ_""""_DVBADLMTR_""""_RONAME_""""_DVBADLMTR
D TST S DVBCCNT=DVBCCNT+1
Q
;
PRINTD ; Print delimited format output on report
;
I OWNDOM']"" S TRNSFIN=""
S RONUM=$P(^DVB(396.3,DA(1),0),U,3)
D DEM^VADPT I $G(VADM(1))'="" S SSN=$S(DVBADLMTR=",":$P($G(VADM(2)),U,2),1:$P($G(VADM(2)),U,1))
S EXAMRECRD=$S($G(ROFILTER)'=0:RONUM_DVBADLMTR,1:"")_""""_ADIV_""""_DVBADLMTR_""""_STATUS_""""_DVBADLMTR_""""_PNAM_""""_DVBADLMTR
S EXAMRECRD=EXAMRECRD_SSN_DVBADLMTR_$C(160)_CNUM_DVBADLMTR_$$FMTE^XLFDT(RDATE1,"5DZ")_DVBADLMTR_EDAYS_DVBADLMTR_TRNSFIN_DVBADLMTR
Q
;
NXT ;F DA(1)=0:0 S DA(1)=$O(^TMP($J,JX,PNAM,DFN,DA(1))) Q:DA(1)="" D PRINT I $D(OUT) S DA(1)="",PNAM="ZZZZ",JX=$S($A(JX)>57:PNAM,1:9999999),DONE="YES"
F DA(1)=0:0 S DA(1)=$O(^TMP($J,JX,PNAM,DFN,DA(1))) Q:DA(1)="" D PRINT
Q
TST F DA=0:0 S DA=$O(^DVB(396.4,"C",DA(1),DA)) Q:DA="" K PRINT S TSTAT=$P(^DVB(396.4,DA,0),U,4),TST=$P(^DVB(396.4,DA,0),U,3),PRTNM=$S($D(^DVB(396.6,TST,0)):$P(^(0),U,2),1:"") D TST1
Q
TST1 S TSTA1=""
I $D(^DVB(396.4,DA,"CAN")) S TSTA1=$P(^DVB(396.4,DA,"CAN"),U,3)
I $D(^DVB(396.4,DA,"TRAN")) S X=$P(^DVB(396.4,DA,"TRAN"),U,3)
S:TSTA1]"" TSTA1=$P(^DVB(396.5,TSTA1,0),U,1)
I $G(DVBADLMTR)'="," D
. S ^TMP("CAPRI",MSGCNT)=$S(PRTNM]"":PRTNM,1:"Missing exam name")
. S ^TMP("CAPRI",MSGCNT)=^TMP("CAPRI",MSGCNT)_$S(TSTA1]"":" - cancelled ("_TSTA1_")",TSTAT="T":" - Transferred",TSTAT]"":" - "_$$EXTERNAL^DILFD(396.4,.04,,TSTAT),TSTAT="":" (Unknown status)",1:"")_"^"
. S MSGCNT=MSGCNT+1
. I TSTAT="T" S X=$S($D(^DIC(4.2,+X,0)):$P(^(0),U,1),1:"unknown site") S ^TMP("CAPRI",MSGCNT)=" to "_$P(X,".",1),MSGCNT=MSGCNT+1
. Q
I $G(DVBADLMTR)="," D
. D CLAIMTYP,SPEC,REROUTE
. S PRTNM=$S(PRTNM]"":PRTNM,1:"Missing exam name"),TSTAT=$S(TSTA1]"":"Cancelled ("_TSTA1_")",TSTAT="T":"Transferred",TSTAT]"":$$EXTERNAL^DILFD(396.4,.04,,TSTAT),TSTAT="":" (Unknown status)",1:"")
. S ^TMP("CAPRI",MSGCNT)=EXAMRECRD_""""_PRTNM_""""_DVBADLMTR_""""_TSTAT_""""_DVBADLMTR_""""_DVBCELL_""""_DVBADLMTR_""""_DVBEMA_""""_DVBADLMTR_""""_DVBCTW_""""_DVBADLMTR_""""_DVBSCWA_""""_DVBADLMTR_""""_DVBRRF_""""_DVBADLMTR_""""_DVBRRT_""""
. I TSTAT="T" S X=$S($D(^DIC(4.2,+X,0)):$P(^(0),U,1),1:"unknown site") S ^TMP("CAPRI",MSGCNT)=^TMP("CAPRI",MSGCNT)_" to "_$P(X,".",1)
. S ^TMP("CAPRI",MSGCNT)=^TMP("CAPRI",MSGCNT)_$C(13)
S MSGCNT=MSGCNT+1
Q
CLAIMTYP ;THE CLAIM TYPE OF A 2507 REQUEST
S DVBCTW=""
Q:'$D(^DVB(396.3,DA(1),9,0))
;DVBIEN is the 2507 REQUEST FILE IEN
;DVBCTW is the string /name of the CLAIM TYPE
D GETS^DIQ(396.3,DA(1)_",","9.1*","E","MSG","ERR")
S DVBCTW=$G(MSG("396.32","1,"_DA(1)_",",".01","E"))
Q
;
SPEC ;SPECIAL CONSIDERATION(S) FOR A 2507 REQUEST
K DVBSCW
S DVBSCWA=""
Q:'$D(^DVB(396.3,DA(1),8))
;DA(1) 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,DA(1),8,0),U,4)
;S DVBAA=$P($G(^DVB(396.3,DA(1),8,0)),U,4)
S (DVBSC,DVBCNT)=0 F S DVBSC=$O(^DVB(396.3,DA(1),8,DVBSC)) Q:'DVBSC D
.S DVBSCN=$P(^DVB(396.3,DA(1),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
;
REROUTE ;REROUTE INFO FOR A 2507 REQUEST
;DVBRRT is site rerouted to
;DVBRRF is the site rerouted from
S (DVBRRT,DVBRRF)=""
Q:'$D(^DVB(396.3,DA(1),6,0))
; quit if no re-route data found
K DVBINC,DVBRRF,DVBRRT
S DVBINC=0
F S DVBINC=$O(^DVB(396.3,DA(1),6,DVBINC)) Q:DVBINC="B" D
. S DVBRRF=$$EXTERNAL^DILFD(396.34,.02,,$P(^DVB(396.3,DA(1),6,DVBINC,0),U,4))
. S DVBRRT=$$EXTERNAL^DILFD(396.34,.02,,$P(^DVB(396.3,DA(1),6,DVBINC,0),U,7))
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBAB6 11008 printed Apr 09, 2024@20:48:28 Page 2
DVBAB6 ;ALB/DJS - CAPRI PENDING 2507 REQUEST REPORT ; 9/8/21 3:59pm
+1 ;;2.7;AMIE;**35,90,108,168,185,190,192,193,227,241**;Apr 10, 1995;Build 4
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
STRT(MSG,DVBCSORT,RSTAT,ERDAYS,OLDAYS,ADIVNUM,ELTYP,DVBADLMTR,ROFILTER) ;
+1 ; MSG=DATA Passed back from RPC to GUI;(.MSG,"A","NR",1,1,7613,"W",0,0)
+2 ;DVBCSORT=Sort by("A"GE,"S"TATUS,"V"ETERAN NAME,"R"OUTING LOCATION)
+3 ;RSTAT= Routing Status("N"ew,"P"ending","T"ranscribed,"NR"New Re-Routed,"RP"Re-routed pending acceptance,"RA"Re-routed acceptance accepted --
+4 ; routing status continued - "RR"Re-routed rejected,"RS"RE-routed pending at to site,'A'll statuses)
+5 ;ERDAYS= Earliest age if SORTBY is "A"("1" earliest, "7" latest)
+6 ;OLDAYS = OLDEST AGE IF SORTBY IS "A"("1"=earliest, "7" oldest)
+7 ;ADIVNUM=ROUTING LOCATION -DIVISION IEN
+8 ;ELTYP= REPORT TYPE("W"ORK DAYS, "C"ALENDAR DAYS)
+9 ;DVBADLMTR= DELIMITER("0"= PLAIN TEXT, "1"=COMMA DELIMITED
+10 ;ROFILTER = MODE ("0"=LOCAL MODE, "1"=REMOTE MODE) SDAT,EDAT,RSTAT,DELIM,YNODT
+11 IF ADIVNUM'=""
SET X=$ORDER(^DG(40.8,"C",ADIVNUM,""))
if X]""
SET ADIVNUM=X
+12 SET DVBADLMTR=$SELECT(DVBADLMTR=1:",",1:0)
SET ROFILTER=$SELECT($GET(ROFILTER)'=0:ROFILTER,1:0)
SETUP KILL ^TMP($JOB),^TMP("CAPRI")
+1 SET DVBCDT(0)=$$FMTE^XLFDT(DT,"5DZ")
SET PG=1
SET DVBCCNT=0
SET DONE="NO"
SET MSGCNT=1
SET TRNSFIN=""
+2 SET DVBCHDR="Sorted by "_$SELECT(DVBCSORT="V":"VETERAN NAME",DVBCSORT="R":"Routing location",DVBCSORT="S":"Status",DVBCSORT="A":"Age of request",1:"Unknown")
HEAD SET HEAD="Pending 2507 Requests for "_$SELECT($DATA(^DVB(396.1,1,0)):$PIECE(^(0),U,1),1:"Unknown site")
SET PROCDT="Processed on: "_DVBCDT(0)
SET NODATA=0
+1 IF $GET(DVBADLMTR)'=","
DO HEADRND
GOTO DATA
+2 IF $GET(DVBADLMTR)=","
DO HEADRD
GOTO DATA
+3 QUIT
HEADRND ; Print non-delimited output header
+1 ;
+2 SET ^TMP("CAPRI",MSGCNT)=HEAD_"^"
SET MSGCNT=MSGCNT+1
+3 SET ^TMP("CAPRI",MSGCNT)=PROCDT_"^"
SET MSGCNT=MSGCNT+1
+4 SET ^TMP("CAPRI",MSGCNT)="^"
SET MSGCNT=MSGCNT+1
+5 SET $PIECE(^TMP("CAPRI",MSGCNT),"=",75)="=^"
SET MSGCNT=MSGCNT+1
+6 SET ^TMP("CAPRI",MSGCNT)="^"
SET MSGCNT=MSGCNT+1
+7 SET ^TMP("CAPRI",MSGCNT)=""
SET MSGCNT=MSGCNT+1
+8 QUIT
HEADRD ; Print delimited output header
+1 ;
+2 SET ^TMP("CAPRI",MSGCNT)=HEAD_$CHAR(13)
SET MSGCNT=MSGCNT+1
SET ^TMP("CAPRI",MSGCNT)=PROCDT_$CHAR(13)
SET MSGCNT=MSGCNT+1
+3 SET ^TMP("CAPRI",MSGCNT)=$SELECT($GET(ROFILTER)'=0:"RO #"_DVBADLMTR,1:"")_"Division"_DVBADLMTR_"Status"_DVBADLMTR_"Veteran Name"_DVBADLMTR_"SSN"_DVBADLMTR_"Claim No."_DVBADLMTR_"Request Date"_DVBADLMTR
+4 SET ^TMP("CAPRI",MSGCNT)=^TMP("CAPRI",MSGCNT)_"Elapsed Days"_DVBADLMTR_"Transferred in from"_DVBADLMTR_"Requested by Name"_DVBADLMTR_"Requested by Division"_DVBADLMTR_"Exams Requested"_DVBADLMTR_"Exam Status"_DVBADLMTR
+5 SET ^TMP("CAPRI",MSGCNT)=^TMP("CAPRI",MSGCNT)_"Cell Phone"_DVBADLMTR_"Email Address"_DVBADLMTR_"Claim Type"_DVBADLMTR_"Special Consideration(s)"_DVBADLMTR_"ReRouted From"_DVBADLMTR_"ReRouted to"_$CHAR(13)
+6 SET MSGCNT=MSGCNT+1
+7 QUIT
+8 ;
DATA ; Sort data records
+1 ;
+2 SET DFN=""
FOR
SET DFN=$ORDER(^DVB(396.3,"B",DFN))
if DFN=""
QUIT
FOR REQDA=0:0
SET REQDA=$ORDER(^DVB(396.3,"B",DFN,REQDA))
if REQDA=""
QUIT
DO SORT^DVBAB5
+3 NEW EXAMRECRD
+4 ;I DVBCSORT="V" S PNAM="" F S PNAM=$O(^TMP($J,PNAM)) Q:PNAM="" F DFN=0:0 S DFN=$O(^TMP($J,PNAM,DFN)) Q:'DFN F DA(1)=0:0 S DA(1)=$O(^TMP($J,PNAM,DFN,DA(1))) Q:'DA(1) D PRINT I $D(OUT) S DA(1)=999999999,PNAM="ZZZ",DONE="YES" Q
+5 IF DVBCSORT="V"
SET PNAM=""
FOR
SET PNAM=$ORDER(^TMP($JOB,PNAM))
if PNAM=""
QUIT
FOR DFN=0:0
SET DFN=$ORDER(^TMP($JOB,PNAM,DFN))
if 'DFN
QUIT
FOR DA(1)=0:0
SET DA(1)=$ORDER(^TMP($JOB,PNAM,DFN,DA(1)))
if 'DA(1)
QUIT
DO PRINT
+6 IF DVBCSORT="R"!(DVBCSORT="A")!(DVBCSORT="S")
Begin DoDot:1
+7 SET JX=""
FOR
SET JX=$ORDER(^TMP($JOB,JX))
if JX=""
QUIT
Begin DoDot:2
+8 SET PNAM=""
FOR
SET PNAM=$ORDER(^TMP($JOB,JX,PNAM))
if PNAM=""
QUIT
Begin DoDot:3
+9 FOR DFN=0:0
SET DFN=$ORDER(^TMP($JOB,JX,PNAM,DFN))
if 'DFN
QUIT
DO NXT
End DoDot:3
End DoDot:2
End DoDot:1
+10 IF DVBCCNT>0
SET ^TMP("CAPRI",MSGCNT)="Total pending: "_DVBCCNT
SET DONE="YES"
+11 ;
EXIT IF NODATA=0
SET ^TMP("CAPRI",MSGCNT)="No pending request found for select parameters."
SET MSG=$NAME(^TMP("CAPRI"))
+1 IF DONE="YES"
SET MSG=$NAME(^TMP("CAPRI"))
+2 KILL ^TMP($JOB),ADIV,CNUM,NODATA,STATUS,TST,TSTA1,STSAT,PG,PRTNM,RDATE,RDATE1,REQDA,SSN,RONAME,JX,TRNSFIN,PROCDT,REQSTR,MSGCNT,TSTAT
+3 KILL DA,DFN,DONE,DVBCCNT,DVBCDT,DVBCHDR,X,XX,ZS,ZZZ,HEAD,HEAD2,OUT,OWNDOM,EDAYS,PNAM,DVBADLMTR,EXAMRECRD,ROFILTER,RONUM,VADM
+4 KILL DVBAA,DVBCELL,DVBCNT,DVBCTW,DVBEMA,DVBSC,DVBSCN,DVBSCNS,DVBSCW,DVBSCWA,DVBX
+5 QUIT
+6 ;
PRINT ; print 2507 request data
+1 ;
+2 SET ADIV=$SELECT($DATA(^DVB(396.3,DA(1),1)):$PIECE(^(1),U,4),1:"")
if ADIV'=ADIVNUM&(DVBCSORT="R")
QUIT
IF ADIV]""
SET ADIV=$SELECT($DATA(^DG(40.8,+ADIV,0)):$PIECE(^(0),U,1),1:"Unknown Division")
+3 SET RDATE1=$PIECE(^DVB(396.3,DA(1),0),U,2)
SET RDATE=$PIECE(^(0),U,5)
+4 SET SSN=$PIECE($GET(^DPT(DFN,0)),U,9)
if SSN=""
SET SSN="Unknown"
+5 SET DVBCELL=$PIECE($GET(^DPT(DFN,.13)),U,4)
+6 SET DVBEMA=$PIECE($GET(^DPT(DFN,.13)),U,3)
+7 SET CNUM=$PIECE($GET(^DPT(DFN,.31)),U,3)
if CNUM=""
SET CNUM="Unknown"
+8 SET OWNDOM=$PIECE(^DVB(396.3,DA(1),0),U,22)
IF OWNDOM]""
SET TRNSFIN=$SELECT($DATA(^DIC(4.2,+OWNDOM,0)):$PIECE(^(0),U,1),1:"Unknown Site")
IF $GET(DVBADLMTR)=0
SET ^TMP("CAPRI",MSGCNT)="Transferred in from "_TRNSFIN_"^"
SET MSGCNT=MSGCNT+1
+9 DO ELAPSED^DVBAB5
+10 ;AJF;Request Status conversion Reports ;
+11 SET STATUS="Unknown"
SET XX=$$RSTAT^DVBCUTL8($PIECE(^DVB(396.3,DA(1),0),U,18))
+12 SET STATUS=$$EXTERNAL^DILFD(396.3,17,,$PIECE(^DVB(396.3,DA(1),0),U,18))
+13 ;S STATUS=$S(XX="N":"New",XX="P":"Pending, reported",XX="S":"Pending, scheduled",XX="R":"Released to RO, not printed",1:"")
+14 ;I STATUS="",$D(XX) S STATUS=$S(XX="C":"Completed, printed by RO",XX="X":"Cancelled by RO",XX="T":"Transcribed",XX="NT":"New,Transferred in",XX="CT":"Completed, Transferred out",1:"Unknown")
+15 IF $GET(DVBADLMTR)=","
DO PRINTD
DO ITEMS
QUIT
+16 SET ^TMP("CAPRI",MSGCNT)="Division: "_ADIV_"^"
SET MSGCNT=MSGCNT+1
+17 SET ^TMP("CAPRI",MSGCNT)="Status: "_STATUS_"^"
SET MSGCNT=MSGCNT+1
+18 SET ^TMP("CAPRI",MSGCNT)=PNAM_" ^"
SET MSGCNT=MSGCNT+1
+19 SET ^TMP("CAPRI",MSGCNT)="SSN: "_SSN_"^"
SET MSGCNT=MSGCNT+1
+20 SET ^TMP("CAPRI",MSGCNT)="Cell no.: "_DVBCELL_"^"
SET MSGCNT=MSGCNT+1
+21 SET ^TMP("CAPRI",MSGCNT)="Email: "_DVBEMA_"^"
SET MSGCNT=MSGCNT+1
+22 SET ^TMP("CAPRI",MSGCNT)="Claim no: "_CNUM_"^"
SET MSGCNT=MSGCNT+1
+23 SET ^TMP("CAPRI",MSGCNT)="Request Date: "_$$FMTE^XLFDT(RDATE1,"5DZ")_"^"
SET MSGCNT=MSGCNT+1
+24 SET ^TMP("CAPRI",MSGCNT)="Elapsed days: "_EDAYS_"^"
SET MSGCNT=MSGCNT+1
+25 SET X=$SELECT($DATA(^DVB(396.3,DA(1),4)):^(4),1:"")
+26 DO CLAIMTYP
DO SPEC
DO REROUTE
+27 SET ^TMP("CAPRI",MSGCNT)="ReRouted From: "_DVBRRF_"^"
SET MSGCNT=MSGCNT+1
+28 SET ^TMP("CAPRI",MSGCNT)="ReRouted To: "_DVBRRT_"^"
SET MSGCNT=MSGCNT+1
+29 SET ^TMP("CAPRI",MSGCNT)="Claim Type: "_DVBCTW_"^"
SET MSGCNT=MSGCNT+1
+30 SET ^TMP("CAPRI",MSGCNT)="Special Consideration(s): "_DVBSCWA_"^"
SET MSGCNT=MSGCNT+1
+31 SET ^TMP("CAPRI",MSGCNT)="^"
SET MSGCNT=MSGCNT+1
+32 SET ^TMP("CAPRI",MSGCNT)="Exams requested:"_"^"
SET MSGCNT=MSGCNT+1
+33 ;
ITEMS SET NODATA=1
SET REQSTR=+$PIECE(^DVB(396.3,DA(1),0),U,4)
+1 SET ZZZ="Requested by: "_$SELECT($DATA(^VA(200,+REQSTR,0)):$PIECE(^(0),U,1),1:" (Not specified) ")_" at "
+2 SET RONAME=$PIECE(^DVB(396.3,DA(1),0),U,3)
SET RONAME=$SELECT(RONAME]"":$PIECE(^DIC(4,+RONAME,0),U,1),1:"")
+3 IF $GET(DVBADLMTR)'=","
DO ITEMSND
QUIT
+4 IF $GET(DVBADLMTR)=","
DO ITEMSD
QUIT
ITEMSND DO TST
SET ^TMP("CAPRI",MSGCNT)="^"_ZZZ_$SELECT(RONAME]"":RONAME,1:" (Not specified) ")_"^"
SET MSGCNT=MSGCNT+1
+1 SET ^TMP("CAPRI",MSGCNT)="^"
SET MSGCNT=MSGCNT+1
+2 SET $PIECE(^TMP("CAPRI",MSGCNT),"-",75)="-^"
SET MSGCNT=MSGCNT+1
+3 SET DVBCCNT=DVBCCNT+1
+4 QUIT
ITEMSD SET ZZZ=$SELECT($DATA(^VA(200,+REQSTR,0)):$PIECE(^(0),U,1),1:" (Not specified) ")
+1 SET EXAMRECRD=EXAMRECRD_""""_ZZZ_""""_DVBADLMTR_""""_RONAME_""""_DVBADLMTR
+2 DO TST
SET DVBCCNT=DVBCCNT+1
+3 QUIT
+4 ;
PRINTD ; Print delimited format output on report
+1 ;
+2 IF OWNDOM']""
SET TRNSFIN=""
+3 SET RONUM=$PIECE(^DVB(396.3,DA(1),0),U,3)
+4 DO DEM^VADPT
IF $GET(VADM(1))'=""
SET SSN=$SELECT(DVBADLMTR=",":$PIECE($GET(VADM(2)),U,2),1:$PIECE($GET(VADM(2)),U,1))
+5 SET EXAMRECRD=$SELECT($GET(ROFILTER)'=0:RONUM_DVBADLMTR,1:"")_""""_ADIV_""""_DVBADLMTR_""""_STATUS_""""_DVBADLMTR_""""_PNAM_""""_DVBADLMTR
+6 SET EXAMRECRD=EXAMRECRD_SSN_DVBADLMTR_$CHAR(160)_CNUM_DVBADLMTR_$$FMTE^XLFDT(RDATE1,"5DZ")_DVBADLMTR_EDAYS_DVBADLMTR_TRNSFIN_DVBADLMTR
+7 QUIT
+8 ;
NXT ;F DA(1)=0:0 S DA(1)=$O(^TMP($J,JX,PNAM,DFN,DA(1))) Q:DA(1)="" D PRINT I $D(OUT) S DA(1)="",PNAM="ZZZZ",JX=$S($A(JX)>57:PNAM,1:9999999),DONE="YES"
+1 FOR DA(1)=0:0
SET DA(1)=$ORDER(^TMP($JOB,JX,PNAM,DFN,DA(1)))
if DA(1)=""
QUIT
DO PRINT
+2 QUIT
TST FOR DA=0:0
SET DA=$ORDER(^DVB(396.4,"C",DA(1),DA))
if DA=""
QUIT
KILL PRINT
SET TSTAT=$PIECE(^DVB(396.4,DA,0),U,4)
SET TST=$PIECE(^DVB(396.4,DA,0),U,3)
SET PRTNM=$SELECT($DATA(^DVB(396.6,TST,0)):$PIECE(^(0),U,2),1:"")
DO TST1
+1 QUIT
TST1 SET TSTA1=""
+1 IF $DATA(^DVB(396.4,DA,"CAN"))
SET TSTA1=$PIECE(^DVB(396.4,DA,"CAN"),U,3)
+2 IF $DATA(^DVB(396.4,DA,"TRAN"))
SET X=$PIECE(^DVB(396.4,DA,"TRAN"),U,3)
+3 if TSTA1]""
SET TSTA1=$PIECE(^DVB(396.5,TSTA1,0),U,1)
+4 IF $GET(DVBADLMTR)'=","
Begin DoDot:1
+5 SET ^TMP("CAPRI",MSGCNT)=$SELECT(PRTNM]"":PRTNM,1:"Missing exam name")
+6 SET ^TMP("CAPRI",MSGCNT)=^TMP("CAPRI",MSGCNT)_$SELECT(TSTA1]"":" - cancelled ("_TSTA1_")",TSTAT="T":" - Transferred",TSTAT]"":" - "_$$EXTERNAL^DILFD(396.4,.04,,TSTAT),TSTAT="":" (Unknown status)",1:"")_"^"
+7 SET MSGCNT=MSGCNT+1
+8 IF TSTAT="T"
SET X=$SELECT($DATA(^DIC(4.2,+X,0)):$PIECE(^(0),U,1),1:"unknown site")
SET ^TMP("CAPRI",MSGCNT)=" to "_$PIECE(X,".",1)
SET MSGCNT=MSGCNT+1
+9 QUIT
End DoDot:1
+10 IF $GET(DVBADLMTR)=","
Begin DoDot:1
+11 DO CLAIMTYP
DO SPEC
DO REROUTE
+12 SET PRTNM=$SELECT(PRTNM]"":PRTNM,1:"Missing exam name")
SET TSTAT=$SELECT(TSTA1]"":"Cancelled ("_TSTA1_")",TSTAT="T":"Transferred",TSTAT]"":$$EXTERNAL^DILFD(396.4,.04,,TSTAT),TSTAT="":" (Unknown status)",1:"")
+13 SET ^TMP("CAPRI",MSGCNT)=EXAMRECRD_""""_PRTNM_""""_DVBADLMTR_""""_TSTAT_""""_DVBADLMTR_""""_DVBCELL_""""_DVBADLMTR_""""_DVBEMA_""""_DVBADLMTR_""""_DVBCTW_""""_DVBADLMTR_""""_DVBSCWA_""""_DVBADLMTR_""""_DVBRRF_""""_DVBADLMTR_""""_DVBRRT_
""""
+14 IF TSTAT="T"
SET X=$SELECT($DATA(^DIC(4.2,+X,0)):$PIECE(^(0),U,1),1:"unknown site")
SET ^TMP("CAPRI",MSGCNT)=^TMP("CAPRI",MSGCNT)_" to "_$PIECE(X,".",1)
+15 SET ^TMP("CAPRI",MSGCNT)=^TMP("CAPRI",MSGCNT)_$CHAR(13)
End DoDot:1
+16 SET MSGCNT=MSGCNT+1
+17 QUIT
CLAIMTYP ;THE CLAIM TYPE OF A 2507 REQUEST
+1 SET DVBCTW=""
+2 if '$DATA(^DVB(396.3,DA(1),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,DA(1)_",","9.1*","E","MSG","ERR")
+6 SET DVBCTW=$GET(MSG("396.32","1,"_DA(1)_",",".01","E"))
+7 QUIT
+8 ;
SPEC ;SPECIAL CONSIDERATION(S) FOR A 2507 REQUEST
+1 KILL DVBSCW
+2 SET DVBSCWA=""
+3 if '$DATA(^DVB(396.3,DA(1),8))
QUIT
+4 ;DA(1) 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,DA(1),8,0),U,4)
+9 ;S DVBAA=$P($G(^DVB(396.3,DA(1),8,0)),U,4)
+10 SET (DVBSC,DVBCNT)=0
FOR
SET DVBSC=$ORDER(^DVB(396.3,DA(1),8,DVBSC))
if 'DVBSC
QUIT
Begin DoDot:1
+11 SET DVBSCN=$PIECE(^DVB(396.3,DA(1),8,DVBSC,0),U,1)
+12 SET DVBSCW(DVBSC)=$GET(^DVB(396.25,DVBSCN,0))
+13 SET DVBCNT=DVBCNT+1
+14 IF (DVBCNT'=DVBAA)
if $DATA(DVBSCW(DVBSC))
SET DVBSCW(DVBSC)=DVBSCW(DVBSC)_","
End DoDot:1
+15 SET DVBX=""
FOR
SET DVBX=$ORDER(DVBSCW(DVBX))
if 'DVBX
QUIT
SET DVBSCWA=DVBSCWA_DVBSCW(DVBX)
+16 QUIT
+17 ;
REROUTE ;REROUTE INFO FOR A 2507 REQUEST
+1 ;DVBRRT is site rerouted to
+2 ;DVBRRF is the site rerouted from
+3 SET (DVBRRT,DVBRRF)=""
+4 if '$DATA(^DVB(396.3,DA(1),6,0))
QUIT
+5 ; quit if no re-route data found
+6 KILL DVBINC,DVBRRF,DVBRRT
+7 SET DVBINC=0
+8 FOR
SET DVBINC=$ORDER(^DVB(396.3,DA(1),6,DVBINC))
if DVBINC="B"
QUIT
Begin DoDot:1
+9 SET DVBRRF=$$EXTERNAL^DILFD(396.34,.02,,$PIECE(^DVB(396.3,DA(1),6,DVBINC,0),U,4))
+10 SET DVBRRT=$$EXTERNAL^DILFD(396.34,.02,,$PIECE(^DVB(396.3,DA(1),6,DVBINC,0),U,7))
End DoDot:1
+11 QUIT
+12 ;
