DVBACER1 ;BEST/JFW - DEMTRAN CONTRACTED EXAM REPORTS ; 6/27/12 3:56pm
;;2.7;AMIE;**178,185,186**;Apr 10, 1995;Build 21
;Per VHA Directive 2004-038, this routine should not be modified.
;
; - RPC: DVBAD CONTRACTED EXAM REPORTS
;
; Creates Detailed, Summary, or Timeliness Contracted Exam Reports
; for the Disability Examination Management Tracking, Referral and
; Notification application (demTRAN).
;
;Input:
; DVBALST: Global array to hold results to be returned
; DVBARTYP: Report Type to Generate (Required)
; D : Detailed
; S : Summary
; T : Timeliness
; DVBAFLTRS: Report Filters (Optional)
; ("DATE") = FM From Date ^ FM To Date (Inclusive)
; ("CONTRACTOR") = IEN of Contractor in 396.45
; ("PENDING") = 1 indicating Pending Exams Only ^
; # of Days Referral Exceeded (Optional)
; ("SORT") = 1 indicating Contractor sorted else
; Request DTM sorted (Detailed Reports Only)
; ("DELIMITTED") = 1 indicating Report returned Delimitted
; (Detailed Reports Only)
;
CERPTS(DVBALST,DVBARTYP,DVBAFLTRS) ;Contracted Exam Reports
N DVBAQ,DVBASDTE,DVBAEDTE,DVBACIEN,DVBAPEXMS,DVBAPDAYS,DVBAHFS
N DVBARIEN,DVBAEIEN,DVBAENDE,DVBAGLBL,DVBARSLTS,DVBASCRH
N DVBACSRT,DVBADLMT,X1,X2,X,%H,%Y
N GETARY,ERARY,RSTAT
K ^TMP($J,"DVBACER1")
S DVBAHFS=$$GETHFS()
S DVBASCRH=$NA(^TMP($J,"DVBASCRATCH"))
S DVBAGLBL=$NA(^TMP($J,"DVBA"_$G(DVBARTYP)_"RPTS"))
S DVBARSLTS=$NA(^TMP("DVBA"_$G(DVBARTYP)_"RSLTS",$J,1))
K @DVBAGLBL,@DVBARSLTS,@DVBASCRH
Q:($$OPENHFS("DVBRP",DVBAHFS,"W",DVBARSLTS)) ;Quit if error
U IO
; Initial start values if filters undefined
S (DVBAEDTE,DVBACIEN)=""
S (DVBASDTE,DVBAPEXMS,DVBAPDAYS,DVBACSRT,DVBADLMT)=0
;
;Date filter defined, set loop conditions
D:($D(DVBAFLTRS("DATE")))
.S DVBASDTE=$P($G(DVBAFLTRS("DATE")),"^")_".2359"
.S X1=DVBASDTE,X2=-1 D C^%DTC S DVBASDTE=X
.S DVBAEDTE=$P($G(DVBAFLTRS("DATE")),"^",2)_".2359"
;Contractor filter defined
S:($D(DVBAFLTRS("CONTRACTOR"))) DVBACIEN=$G(DVBAFLTRS("CONTRACTOR"))
;Pending Exam filter defined
D:($D(DVBAFLTRS("PENDING")))
.S DVBAPEXMS=1,DVBAPDAYS=+$P($G(DVBAFLTRS("PENDING")),"^",2)
;Sorting (Contractor or Request DTM - for Detailed Reports Only)
S:($D(DVBAFLTRS("SORT"))) DVBACSRT=1
;Delimitted Output (for Detailed Reports Only)
S:($D(DVBAFLTRS("DELIMITTED"))) DVBADLMT=1
;
;Get Contractor(s) list for Timeliness and Summary Reports
; if specific contractor NOT defined
D:(($G(DVBARTYP)'="D")&(DVBACIEN']"")) CONLST(DVBACIEN,DVBARSLTS)
;
;Use "C" X-REF so results are in Date/Time Order
F S DVBASDTE=$O(^DVB(396.3,"C",DVBASDTE)) Q:('+DVBASDTE)!((DVBAEDTE]"")&(DVBASDTE>DVBAEDTE)) D
.S DVBARIEN="" ;In case there is more than 1 request ien for dtm
.F S DVBARIEN=$O(^DVB(396.3,"C",DVBASDTE,DVBARIEN)) Q:'+DVBARIEN D
..;Use "C" X-REF for retrieving exams for request IEN
..I ($G(DVBARTYP)="T") D CERPTS2 Q
..S DVBAEIEN=""
..F S DVBAEIEN=$O(^DVB(396.4,"C",DVBARIEN,DVBAEIEN)) Q:'+DVBAEIEN D
...S DVBAENDE=$G(^DVB(396.4,DVBAEIEN,"CNTRCTR"))
...;Ignore exams that have NOT been contracted out
...;Q:($P(DVBAENDE,"^",2)']"")
...I ($P(DVBAENDE,"^",2)']"") Q
...;Ignore exams NOT for specified contractor if defined
...;Q:((DVBACIEN]"")&(DVBACIEN'=(+DVBAENDE)))
...I ((DVBACIEN]"")&(DVBACIEN'=(+DVBAENDE))) Q
...;DETAILED & SUMMARY REPORTING
...D:($G(DVBARTYP)'="T")
....S DVBAQ=0
....I (DVBAPEXMS) D Q:(DVBAQ) ;Pending Exams
.....;Ignore Exams NOT received back from contractor
.....S:($P(DVBAENDE,"^",3)]"") DVBAQ=1
.....D:(('DVBAQ)&(DVBAPDAYS]""))
......;Ignore Pending Exams less than requested days
......S X1=DT,X2=$P(DVBAENDE,"^",2) D ^%DTC
......S:(X<=DVBAPDAYS) DVBAQ=1
....D:($G(DVBARTYP)="D") DRPTS(DVBACSRT,DVBARIEN,DVBAEIEN,DVBASCRH)
....D:($G(DVBARTYP)="S") SRPTS(DVBARIEN,DVBAENDE,DVBAGLBL,DVBARSLTS)
..D:($G(DVBARTYP)="T") TRPTS3(DVBAGLBL,DVBARSLTS)
D:($G(DVBARTYP)="D") DSPLYDTL(DVBACSRT,DVBACIEN,DVBAPEXMS,DVBASCRH,DVBADLMT) ;Rpt Details
D CLOSEHFS("DVBRP",DVBAHFS,DVBARSLTS)
S DVBALST=$NA(@DVBARSLTS)
K @DVBAGLBL,@DVBASCRH
Q
;
;
CERPTS2 ;Logic for timeliness report
N EXSTAT
K ^TMP($J,"DVBACER1")
S DVBAEIEN=""
F S DVBAEIEN=$O(^DVB(396.4,"C",DVBARIEN,DVBAEIEN)) Q:'+DVBAEIEN D
.S DVBAENDE=$G(^DVB(396.4,DVBAEIEN,"CNTRCTR"))
.;Ignore exams that have NOT been contracted out
.Q:($P(DVBAENDE,"^",2)']"")
.;Ignore exams NOT for specified contractor if defined
.Q:((DVBACIEN]"")&(DVBACIEN'=(+DVBAENDE)))
.;TIMELINESS REPORTING
.;Innore exams that have been canceled
.S EXSTAT=$P(^DVB(396.4,DVBAEIEN,0),"^",4)
.Q:EXSTAT="X"!(EXSTAT="RX")
.D TRPTS2(DVBAENDE)
D TRPTS3(DVBAGLBL,DVBARSLTS)
Q
;
;Input DVBACIEN - Specific Contrator Data Requested
; DVBARSLTS - Global Refernece for results
;Output Global Array Entries Added for Contractor(s)
; ^TMP("DVBATRSLTS",$J)
CONLST(DVBACIEN,DVBARSLTS) ;Get Contractor List
;Used in Timeliness and Summary Reports
N DVBACNDE
;Specific Contractor Info Requested
I (DVBACIEN]"") D Q
.S DVBACNDE=$G(^DVB(396.45,DVBACIEN,0))
.S @DVBARSLTS@(DVBACIEN)=$P(DVBACNDE,"^")_"^"_$P(DVBACNDE,"^",3)_"^"
;All Contractor Info Requested
S DVBACIEN=0 F S DVBACIEN=$O(^DVB(396.45,DVBACIEN)) Q:'+DVBACIEN D
.S DVBACNDE=$G(^DVB(396.45,DVBACIEN,0))
.;Create list of contractor info and initialize counters
.; for the specific report to 0
.S @DVBARSLTS@($P(DVBACNDE,"^"),DVBACIEN)=$P(DVBACNDE,"^")_"^"_$P(DVBACNDE,"^",3)_"^0"
.S:($G(DVBARTYP)="S") @DVBARSLTS@($P(DVBACNDE,"^"),DVBACIEN)=@DVBARSLTS@($P(DVBACNDE,"^"),DVBACIEN)_"^0"
Q
;
;Input DVBACSRT - 1/0 if report should be sorted by Contractor
; Name (1) or by Request Date (0)
; DVBARIEN - IEN of Request (396.3) associated with Exam
; DVBAEIEN - IEN of Exam (396.4)
; DVBASCRH - Global Reference for results (Scratch Global)
;Output Global Array Entry Added (Sorted) - ^TMP($J,"DVBASCRH")
DRPTS(DVBACSRT,DVBARIEN,DVBAEIEN,DVBASCRH) ; Detailed Report Processing
N DVBACNME,DVBAENME,DVBARDTM,DVBAEXM
;Retrieve Exam Info
D GETS^DIQ(396.4,DVBAEIEN_",",".03;100","E","DVBAEXM")
S DVBACNME=$G(DVBAEXM(396.4,DVBAEIEN_",",100,"E")) ;Contractor
S:(DVBACNME']"") DVBACNME="UNKNOWN"
S DVBAENME=$G(DVBAEXM(396.4,DVBAEIEN_",",.03,"E")) ;Exam Name
S:(DVBAENME']"") DVBAENME="UNKNOWN"
S DVBAENME=$TR(DVBAENME,","," ") ;Remove Commas
S DVBARDTM=$P($G(^DVB(396.3,DVBARIEN,0)),"^",2) ;Request DateTime
S:('DVBACSRT) @DVBASCRH@(DVBARDTM,DVBARIEN,DVBAENME,DVBAEIEN)=""
S:(DVBACSRT) @DVBASCRH@($TR(DVBACNME,","," "),DVBARDTM,DVBARIEN,DVBAENME,DVBAEIEN)=DVBACNME
Q
;
;Input DVBACSRT - 1/0 if report should be sorted by Contractor
; Name (1) or by Request Date (0)
; DVBAEIEN - IEN of Exam (396.4)
; DVBAPEXMS - 1/0 Indicates if only pending exams report
; DVBASCRH - Global Reference for results (Scratch Global)
; DVBADLMT - 1/0 if report output should be delimitted
; Delimitted Output (1) or Formatted Output (0)
;Output Write Report Details
DSPLYDTL(DVBACSRT,DVBACIEN,DVBAPEXMS,DVBASCRH,DVBADLMT) ;Display Sorted Detailed Report Info
N DVBAREF,DVBACNME,DVBARIEN,DVBAINFO,DVBAOFST
N DVBASPCG,DVBALNE,DFN,VADM,X
D DRPTSPCG(DVBACSRT,DVBADLMT,.DVBASPCG)
S DVBAREF=DVBASCRH,DVBAOFST=0,(DVBACNME,DVBARIEN)=""
S:('DVBACSRT) DVBAOFST=1
;Quit if no results found
Q:('$D(@DVBASCRH))
;Report Column Header Info
W:((DVBACIEN']"")&(DVBACSRT)) "Contractor",$S(DVBADLMT:"^",1:"")
W:((DVBACIEN']"")&(DVBACSRT)&('DVBADLMT)) !
W ?DVBASPCG(1),"Request Date",$S(DVBADLMT:"^",1:""),?DVBASPCG(2),"SSN",$S(DVBADLMT:"^",1:"")
W ?DVBASPCG(3),"Patient Name",$S(DVBADLMT:"^",1:""),?DVBASPCG(4),"Status",$S(DVBADLMT:"^",1:"")
W:('DVBADLMT) !
W ?DVBASPCG(5),"Examinations",$S(DVBADLMT:"^",1:"")
W:(('DVBACSRT)&(DVBACIEN']"")) ?DVBASPCG(6),"Contractor",$S(DVBADLMT:"^",1:"")
W ?DVBASPCG(7),"Referred"
S DVBALNE=(DVBASPCG(7)+18)
D:('DVBAPEXMS)
.W ?DVBASPCG(8),$S(DVBADLMT:"^",1:""),"Received"
.S DVBALNE=(DVBASPCG(8)+12)
S X="" S $P(X,"-",DVBALNE)="-" W:('DVBADLMT) !,X ;Header Line
F S DVBAREF=$Q(@DVBAREF) Q:(DVBAREF'[$P(DVBASCRH,")")) D
.;Display Contractor Name, if NOT specific contractor report
.D:((DVBACIEN']"")&(DVBACSRT)&(DVBADLMT)) ; Delimitted Output
..W !,@DVBAREF_"^"
.D:((DVBACNME'=@DVBAREF)&(DVBACIEN']"")&(DVBACSRT)&('DVBADLMT)) ;Formatted Output
..W:(DVBACNME]"") ! ;Extra Line Space between Contractors
..S DVBACNME=@DVBAREF
..W !,DVBACNME
.;Display Request Info (Multiple Exams)
.D:(DVBARIEN'=$P(DVBAREF,",",(5-DVBAOFST)))
..S DVBARIEN=$P(DVBAREF,",",(5-DVBAOFST))
..S DFN=+$G(^DVB(396.3,DVBARIEN,0)) ; Patient
..D DEM^VADPT ;DBIA: 10061
..D GETS^DIQ(396.3,DVBARIEN_",","17","E","DVBAINFO")
..D:('DVBADLMT) ;Formatted Report
...W !?DVBASPCG(1),$$FMTE^XLFDT($P(DVBAREF,",",(4-DVBAOFST)),"M") ;No Seconds
...W ?DVBASPCG(2),$P($G(VADM(2)),"^",2),?DVBASPCG(3),$G(VADM(1))
...W ?DVBASPCG(4),$G(DVBAINFO(396.3,DVBARIEN_",",17,"E"))
.D:(DVBADLMT) ;Detailed Report
..W:'((DVBACIEN']"")&(DVBACSRT)) !
..W $$FMTE^XLFDT($P(DVBAREF,",",(4-DVBAOFST)),"M")_"^" ;No Seconds
..W $P($G(VADM(2)),"^",2)_"^"_$G(VADM(1))_"^"
..W $G(DVBAINFO(396.3,DVBARIEN_",",17,"E"))_"^"
.;Exam Info for Request
.D EXMINFO(DVBAPEXMS,+$P(DVBAREF,",",(7-DVBAOFST)),DVBACSRT,DVBADLMT,.DVBASPCG)
K DVBAINFO,VADM
Q
;
;Input DVBAPEXMS - 1/0 Indicates if only pending exams report
; DVBAEIEN - IEN of Exam (396.4)
; DVBACSRT - 1/0 if report should be sorted by Contractor
; Name (1) or by Request Date (0)
; DVBADLMT - 1/0 if report output should be delimitted
; Delimitted Output (1) or Formatted Output (0)
; DVBASPCG - Array to store spacing (By Ref)
;Output Write EXAM Info for request to report
EXMINFO(DVBAPEXMS,DVBAEIEN,DVBACSRT,DVBADLMT,DVBASPCG) ;Display Exam Info
N DVBAEXM
;Retrieve exam info for display on report
D GETS^DIQ(396.4,DVBAEIEN_",",".03;100;101;102","EI","DVBAEXM")
W:('DVBADLMT) !
W ?DVBASPCG(5),$G(DVBAEXM(396.4,DVBAEIEN_",",.03,"E")),$S(DVBADLMT:"^",1:"")
W:('DVBACSRT) ?DVBASPCG(6),$G(DVBAEXM(396.4,DVBAEIEN_",",100,"E")),$S(DVBADLMT:"^",1:"")
W ?DVBASPCG(7),$$FMTE^XLFDT($P($G(DVBAEXM(396.4,DVBAEIEN_",",101,"I")),"@"),"M"),$S(DVBADLMT:"^",1:"")
W:('DVBAPEXMS) ?DVBASPCG(8),$P($G(DVBAEXM(396.4,DVBAEIEN_",",102,"E")),"@")
Q
;
;Input DVBACSRT - 1/0 if report should be sorted by Contractor
; Name (1) or by Request Date (0)
; DVBADLMT - 1/0 if report output should be delimitted
; Delimitted Output (1) or Formatted Output (0)
; DVBASPCG - Array to store spacing (By Ref)
DRPTSPCG(DVBACSRT,DVBADLMT,DVBASPCG) ;Setup Detailed Report Spacing
N DVBAOFST,DVBAI
S DVBAOFST=0 S:('DVBACSRT&'DVBADLMT) DVBAOFST=3
K DVBASPCG
D:(DVBADLMT)
.F DVBAI=1:1:8 S DVBASPCG(DVBAI)=0
D:('DVBADLMT)
.S DVBASPCG(1)=3-DVBAOFST,DVBASPCG(2)=23-DVBAOFST
.S DVBASPCG(3)=36-DVBAOFST,DVBASPCG(4)=68-DVBAOFST
.S DVBASPCG(5)=5-DVBAOFST,DVBASPCG(6)=70-DVBAOFST
.S:(DVBACSRT) DVBASPCG(7)=70-DVBAOFST,DVBASPCG(8)=91-DVBAOFST
.S:('DVBACSRT) DVBASPCG(7)=101,DVBASPCG(8)=121
Q
;
;Input DVBARIEN - IEN of Request (396.3) associated with Exam
; DVBACNDE - CNTRCTR Node for Exam IEN in 396.4
; DVBAGLBL - Global Reference for Requests Counted
; DVBARSLTS - Global Reference for results
;Output Global Array Entries Updated for Contractor if applicable
; ^TMP($J,"DVBATRPTS") / ^TMP("DVBATRSLTS",$J)
SRPTS(DVBARIEN,DVBACNDE,DVBAGLBL,DVBARSLTS) ;Summary Report Processing
N DVBACNTR,DVBACNME
S DVBACNME=$P($G(^DVB(396.45,+$P(DVBACNDE,"^"),0)),"^")
;Retrieve current number of exams referred by contractor
S DVBACNTR=$P($G(@DVBARSLTS@(DVBACNME,+$P(DVBACNDE,"^"))),"^",3)
;Increment Number of Exams referred for contractor
S $P(@DVBARSLTS@(DVBACNME,+$P(DVBACNDE,"^")),"^",3)=DVBACNTR+1
;Increment 2507 Request Counter if IEN NOT already counted for Contractor
D:('$D(@DVBAGLBL@(+$P(DVBACNDE,"^"),DVBARIEN)))
.S @DVBAGLBL@(+$P(DVBACNDE,"^"),DVBARIEN)="" ;Add request IEN to list
.S DVBACNTR=$P($G(@DVBARSLTS@(DVBACNME,+$P(DVBACNDE,"^"))),"^",4)
.;Increment # of 2507 Request referred to contractor
.S $P(@DVBARSLTS@(DVBACNME,+$P(DVBACNDE,"^")),"^",4)=DVBACNTR+1
Q
;
;Input DVBACNDE - CNTRCTR Node for Exam IEN in 396.4
; DVBAGLBL - Global Reference for Timeliness counters
; DVBARSLTS - Global Reference for results
;Output Global Array Entries Updated for Contractor if applicable
; ^TMP($J,"DVBATRPTS") / ^TMP("DVBATRSLTS",$J)
TRPTS(DVBACNDE,DVBAGLBL,DVBARSLTS,DVBATVAL) ;Timeliness Report Processing
N DVBACNME,DVBANDAYS,DVBANEXMS
;Ignore Exams NOT returned (Checked-In) by Contractor
S DVBANDAYS=+$G(@DVBAGLBL@(+$P(DVBACNDE,"^"),"DAYS"))
S DVBANEXMS=+$G(@DVBAGLBL@(+$P(DVBACNDE,"^"),"EXMS"))
;Increment Timeliness Counter (Total # of Days)
S @DVBAGLBL@(+$P(DVBACNDE,"^"),"DAYS")=DVBANDAYS+DVBATVAL
;Increment Number of Exams Found
S @DVBAGLBL@(+$P(DVBACNDE,"^"),"EXMS")=DVBANEXMS+1
S DVBACNME=$P($G(^DVB(396.45,+$P(DVBACNDE,"^"),0)),"^")
;Update Average Timeliness result for Contractor
S $P(@DVBARSLTS@(DVBACNME,+$P(DVBACNDE,"^")),"^",3)=$FN((DVBANDAYS+DVBATVAL)/(DVBANEXMS+1),"",0)
Q
;
TRPTS2(DVBACNDE) ;Timeliness include logic
N DVBACNME,DVBATVAL,DVBANDAYS,DVBANEXMS,X1,X2,X,%Y
N DVBAEXM2,STAT
K ^TMP($J,"DVBACER1.FLAG")
D GETS^DIQ(396.4,DVBAEIEN_",",".03;.04;100;101;102","EI","DVBAEXM2")
S STAT=$G(DVBAEXM2(396.4,DVBAEIEN_",",.04,"I"))
S CNTR=$G(DVBAEXM2(396.4,DVBAEIEN_",",100,"I")) S:$G(CNTR)="" CNTR="X"
S X1=$P(DVBACNDE,"^",3),X2=$P(DVBACNDE,"^",2) D ^%DTC
I $P(DVBACNDE,"^",3)="" S ^TMP($J,"DVBACER1.FLAG",CNTR)=1
S DVBATVAL=X ;# Days between CheckIn and CheckOut
S:DVBATVAL="" DVBATVAL=0
S ^TMP($J,"DVBACER1",CNTR,DVBATVAL)=DVBACNDE_"|"_STAT
Q
;
TRPTS3(DVBAGLBL,DVBARSLTS) ;Timeliness calculation section
Q:'$D(^TMP($J,"DVBACER1"))
N OPENEXM,CNTR,DVBATVAL
S CNTR="" F S CNTR=$O(^TMP($J,"DVBACER1",CNTR)) Q:CNTR="" D
.Q:CNTR="X"
.Q:$G(^TMP($J,"DVBACER1.FLAG",CNTR))=1
.S OPENEXM(CNTR)=0
.S DVBATVAL="" F S DVBATVAL=$O(^TMP($J,"DVBACER1",CNTR,DVBATVAL)) Q:DVBATVAL=""!(OPENEXM(CNTR)=1) D
..I $P(^TMP($J,"DVBACER1",CNTR,DVBATVAL),"|",2)'="C" S OPENEXM(CNTR)=1 Q
S CNTR="" F S CNTR=$O(OPENEXM(CNTR)) Q:CNTR="" D
.Q:OPENEXM(CNTR)=1
.S DVBATVAL=$O(^TMP($J,"DVBACER1",CNTR,""),-1),DVBACNDE=$P(^TMP($J,"DVBACER1",CNTR,DVBATVAL),"|",1) D
..Q:DVBATVAL=0
..D TRPTS(DVBACNDE,DVBAGLBL,DVBARSLTS,DVBATVAL)
K ^TMP($J,"DVBACER1")
K ^TMP($J,"DVBACER1.FLAG")
;
GETHFS() ;Get HFS File Name
N DVBAH
S DVBAH=$H
Q "DVBA_"_$J_"_"_$P(DVBAH,",")_"_"_$P(DVBAH,",",2)_".DAT"
;
OPENHFS(DVBAHNDL,DVBAHFS,DVBAMODE,DVBARSLTS) ;Open HFS File
N DVBAERR,POP
S DVBAERR=0
D OPEN^%ZISH(DVBAHNDL,,DVBAHFS,$G(DVBAMODE,"W")) D:POP Q:POP
.S DVBAERR=1,@DVBARSLTS@(1)="0^Unable to open HFS file."
Q DVBAERR
;
CLOSEHFS(DVBAHNDL,DVBAHFS,DVBARSLTS) ;Close HFS and unload data
N DVBADEL,X,%ZIS
D CLOSE^%ZISH(DVBAHNDL)
S DVBADEL(DVBAHFS)=""
S X=$$FTG^%ZISH(,DVBAHFS,$NA(@DVBARSLTS@(1)),4)
S X=$$DEL^%ZISH(,$NA(DVBADEL))
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBACER1 15515 printed Apr 09, 2024@20:58:40 Page 2
DVBACER1 ;BEST/JFW - DEMTRAN CONTRACTED EXAM REPORTS ; 6/27/12 3:56pm
+1 ;;2.7;AMIE;**178,185,186**;Apr 10, 1995;Build 21
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
+4 ; - RPC: DVBAD CONTRACTED EXAM REPORTS
+5 ;
+6 ; Creates Detailed, Summary, or Timeliness Contracted Exam Reports
+7 ; for the Disability Examination Management Tracking, Referral and
+8 ; Notification application (demTRAN).
+9 ;
+10 ;Input:
+11 ; DVBALST: Global array to hold results to be returned
+12 ; DVBARTYP: Report Type to Generate (Required)
+13 ; D : Detailed
+14 ; S : Summary
+15 ; T : Timeliness
+16 ; DVBAFLTRS: Report Filters (Optional)
+17 ; ("DATE") = FM From Date ^ FM To Date (Inclusive)
+18 ; ("CONTRACTOR") = IEN of Contractor in 396.45
+19 ; ("PENDING") = 1 indicating Pending Exams Only ^
+20 ; # of Days Referral Exceeded (Optional)
+21 ; ("SORT") = 1 indicating Contractor sorted else
+22 ; Request DTM sorted (Detailed Reports Only)
+23 ; ("DELIMITTED") = 1 indicating Report returned Delimitted
+24 ; (Detailed Reports Only)
+25 ;
CERPTS(DVBALST,DVBARTYP,DVBAFLTRS) ;Contracted Exam Reports
+1 NEW DVBAQ,DVBASDTE,DVBAEDTE,DVBACIEN,DVBAPEXMS,DVBAPDAYS,DVBAHFS
+2 NEW DVBARIEN,DVBAEIEN,DVBAENDE,DVBAGLBL,DVBARSLTS,DVBASCRH
+3 NEW DVBACSRT,DVBADLMT,X1,X2,X,%H,%Y
+4 NEW GETARY,ERARY,RSTAT
+5 KILL ^TMP($JOB,"DVBACER1")
+6 SET DVBAHFS=$$GETHFS()
+7 SET DVBASCRH=$NAME(^TMP($JOB,"DVBASCRATCH"))
+8 SET DVBAGLBL=$NAME(^TMP($JOB,"DVBA"_$GET(DVBARTYP)_"RPTS"))
+9 SET DVBARSLTS=$NAME(^TMP("DVBA"_$GET(DVBARTYP)_"RSLTS",$JOB,1))
+10 KILL @DVBAGLBL,@DVBARSLTS,@DVBASCRH
+11 ;Quit if error
if ($$OPENHFS("DVBRP",DVBAHFS,"W",DVBARSLTS))
QUIT
+12 USE IO
+13 ; Initial start values if filters undefined
+14 SET (DVBAEDTE,DVBACIEN)=""
+15 SET (DVBASDTE,DVBAPEXMS,DVBAPDAYS,DVBACSRT,DVBADLMT)=0
+16 ;
+17 ;Date filter defined, set loop conditions
+18 if ($DATA(DVBAFLTRS("DATE")))
Begin DoDot:1
+19 SET DVBASDTE=$PIECE($GET(DVBAFLTRS("DATE")),"^")_".2359"
+20 SET X1=DVBASDTE
SET X2=-1
DO C^%DTC
SET DVBASDTE=X
+21 SET DVBAEDTE=$PIECE($GET(DVBAFLTRS("DATE")),"^",2)_".2359"
End DoDot:1
+22 ;Contractor filter defined
+23 if ($DATA(DVBAFLTRS("CONTRACTOR")))
SET DVBACIEN=$GET(DVBAFLTRS("CONTRACTOR"))
+24 ;Pending Exam filter defined
+25 if ($DATA(DVBAFLTRS("PENDING")))
Begin DoDot:1
+26 SET DVBAPEXMS=1
SET DVBAPDAYS=+$PIECE($GET(DVBAFLTRS("PENDING")),"^",2)
End DoDot:1
+27 ;Sorting (Contractor or Request DTM - for Detailed Reports Only)
+28 if ($DATA(DVBAFLTRS("SORT")))
SET DVBACSRT=1
+29 ;Delimitted Output (for Detailed Reports Only)
+30 if ($DATA(DVBAFLTRS("DELIMITTED")))
SET DVBADLMT=1
+31 ;
+32 ;Get Contractor(s) list for Timeliness and Summary Reports
+33 ; if specific contractor NOT defined
+34 if (($GET(DVBARTYP)'="D")&(DVBACIEN']""))
DO CONLST(DVBACIEN,DVBARSLTS)
+35 ;
+36 ;Use "C" X-REF so results are in Date/Time Order
+37 FOR
SET DVBASDTE=$ORDER(^DVB(396.3,"C",DVBASDTE))
if ('+DVBASDTE)!((DVBAEDTE]"")&(DVBASDTE>DVBAEDTE))
QUIT
Begin DoDot:1
+38 ;In case there is more than 1 request ien for dtm
SET DVBARIEN=""
+39 FOR
SET DVBARIEN=$ORDER(^DVB(396.3,"C",DVBASDTE,DVBARIEN))
if '+DVBARIEN
QUIT
Begin DoDot:2
+40 ;Use "C" X-REF for retrieving exams for request IEN
+41 IF ($GET(DVBARTYP)="T")
DO CERPTS2
QUIT
+42 SET DVBAEIEN=""
+43 FOR
SET DVBAEIEN=$ORDER(^DVB(396.4,"C",DVBARIEN,DVBAEIEN))
if '+DVBAEIEN
QUIT
Begin DoDot:3
+44 SET DVBAENDE=$GET(^DVB(396.4,DVBAEIEN,"CNTRCTR"))
+45 ;Ignore exams that have NOT been contracted out
+46 ;Q:($P(DVBAENDE,"^",2)']"")
+47 IF ($PIECE(DVBAENDE,"^",2)']"")
QUIT
+48 ;Ignore exams NOT for specified contractor if defined
+49 ;Q:((DVBACIEN]"")&(DVBACIEN'=(+DVBAENDE)))
+50 IF ((DVBACIEN]"")&(DVBACIEN'=(+DVBAENDE)))
QUIT
+51 ;DETAILED & SUMMARY REPORTING
+52 if ($GET(DVBARTYP)'="T")
Begin DoDot:4
+53 SET DVBAQ=0
+54 ;Pending Exams
IF (DVBAPEXMS)
Begin DoDot:5
+55 ;Ignore Exams NOT received back from contractor
+56 if ($PIECE(DVBAENDE,"^",3)]"")
SET DVBAQ=1
+57 if (('DVBAQ)&(DVBAPDAYS]""))
Begin DoDot:6
+58 ;Ignore Pending Exams less than requested days
+59 SET X1=DT
SET X2=$PIECE(DVBAENDE,"^",2)
DO ^%DTC
+60 if (X<=DVBAPDAYS)
SET DVBAQ=1
End DoDot:6
End DoDot:5
if (DVBAQ)
QUIT
+61 if ($GET(DVBARTYP)="D")
DO DRPTS(DVBACSRT,DVBARIEN,DVBAEIEN,DVBASCRH)
+62 if ($GET(DVBARTYP)="S")
DO SRPTS(DVBARIEN,DVBAENDE,DVBAGLBL,DVBARSLTS)
End DoDot:4
End DoDot:3
+63 if ($GET(DVBARTYP)="T")
DO TRPTS3(DVBAGLBL,DVBARSLTS)
End DoDot:2
End DoDot:1
+64 ;Rpt Details
if ($GET(DVBARTYP)="D")
DO DSPLYDTL(DVBACSRT,DVBACIEN,DVBAPEXMS,DVBASCRH,DVBADLMT)
+65 DO CLOSEHFS("DVBRP",DVBAHFS,DVBARSLTS)
+66 SET DVBALST=$NAME(@DVBARSLTS)
+67 KILL @DVBAGLBL,@DVBASCRH
+68 QUIT
+69 ;
+70 ;
CERPTS2 ;Logic for timeliness report
+1 NEW EXSTAT
+2 KILL ^TMP($JOB,"DVBACER1")
+3 SET DVBAEIEN=""
+4 FOR
SET DVBAEIEN=$ORDER(^DVB(396.4,"C",DVBARIEN,DVBAEIEN))
if '+DVBAEIEN
QUIT
Begin DoDot:1
+5 SET DVBAENDE=$GET(^DVB(396.4,DVBAEIEN,"CNTRCTR"))
+6 ;Ignore exams that have NOT been contracted out
+7 if ($PIECE(DVBAENDE,"^",2)']"")
QUIT
+8 ;Ignore exams NOT for specified contractor if defined
+9 if ((DVBACIEN]"")&(DVBACIEN'=(+DVBAENDE)))
QUIT
+10 ;TIMELINESS REPORTING
+11 ;Innore exams that have been canceled
+12 SET EXSTAT=$PIECE(^DVB(396.4,DVBAEIEN,0),"^",4)
+13 if EXSTAT="X"!(EXSTAT="RX")
QUIT
+14 DO TRPTS2(DVBAENDE)
End DoDot:1
+15 DO TRPTS3(DVBAGLBL,DVBARSLTS)
+16 QUIT
+17 ;
+18 ;Input DVBACIEN - Specific Contrator Data Requested
+19 ; DVBARSLTS - Global Refernece for results
+20 ;Output Global Array Entries Added for Contractor(s)
+21 ; ^TMP("DVBATRSLTS",$J)
CONLST(DVBACIEN,DVBARSLTS) ;Get Contractor List
+1 ;Used in Timeliness and Summary Reports
+2 NEW DVBACNDE
+3 ;Specific Contractor Info Requested
+4 IF (DVBACIEN]"")
Begin DoDot:1
+5 SET DVBACNDE=$GET(^DVB(396.45,DVBACIEN,0))
+6 SET @DVBARSLTS@(DVBACIEN)=$PIECE(DVBACNDE,"^")_"^"_$PIECE(DVBACNDE,"^",3)_"^"
End DoDot:1
QUIT
+7 ;All Contractor Info Requested
+8 SET DVBACIEN=0
FOR
SET DVBACIEN=$ORDER(^DVB(396.45,DVBACIEN))
if '+DVBACIEN
QUIT
Begin DoDot:1
+9 SET DVBACNDE=$GET(^DVB(396.45,DVBACIEN,0))
+10 ;Create list of contractor info and initialize counters
+11 ; for the specific report to 0
+12 SET @DVBARSLTS@($PIECE(DVBACNDE,"^"),DVBACIEN)=$PIECE(DVBACNDE,"^")_"^"_$PIECE(DVBACNDE,"^",3)_"^0"
+13 if ($GET(DVBARTYP)="S")
SET @DVBARSLTS@($PIECE(DVBACNDE,"^"),DVBACIEN)=@DVBARSLTS@($PIECE(DVBACNDE,"^"),DVBACIEN)_"^0"
End DoDot:1
+14 QUIT
+15 ;
+16 ;Input DVBACSRT - 1/0 if report should be sorted by Contractor
+17 ; Name (1) or by Request Date (0)
+18 ; DVBARIEN - IEN of Request (396.3) associated with Exam
+19 ; DVBAEIEN - IEN of Exam (396.4)
+20 ; DVBASCRH - Global Reference for results (Scratch Global)
+21 ;Output Global Array Entry Added (Sorted) - ^TMP($J,"DVBASCRH")
DRPTS(DVBACSRT,DVBARIEN,DVBAEIEN,DVBASCRH) ; Detailed Report Processing
+1 NEW DVBACNME,DVBAENME,DVBARDTM,DVBAEXM
+2 ;Retrieve Exam Info
+3 DO GETS^DIQ(396.4,DVBAEIEN_",",".03;100","E","DVBAEXM")
+4 ;Contractor
SET DVBACNME=$GET(DVBAEXM(396.4,DVBAEIEN_",",100,"E"))
+5 if (DVBACNME']"")
SET DVBACNME="UNKNOWN"
+6 ;Exam Name
SET DVBAENME=$GET(DVBAEXM(396.4,DVBAEIEN_",",.03,"E"))
+7 if (DVBAENME']"")
SET DVBAENME="UNKNOWN"
+8 ;Remove Commas
SET DVBAENME=$TRANSLATE(DVBAENME,","," ")
+9 ;Request DateTime
SET DVBARDTM=$PIECE($GET(^DVB(396.3,DVBARIEN,0)),"^",2)
+10 if ('DVBACSRT)
SET @DVBASCRH@(DVBARDTM,DVBARIEN,DVBAENME,DVBAEIEN)=""
+11 if (DVBACSRT)
SET @DVBASCRH@($TRANSLATE(DVBACNME,","," "),DVBARDTM,DVBARIEN,DVBAENME,DVBAEIEN)=DVBACNME
+12 QUIT
+13 ;
+14 ;Input DVBACSRT - 1/0 if report should be sorted by Contractor
+15 ; Name (1) or by Request Date (0)
+16 ; DVBAEIEN - IEN of Exam (396.4)
+17 ; DVBAPEXMS - 1/0 Indicates if only pending exams report
+18 ; DVBASCRH - Global Reference for results (Scratch Global)
+19 ; DVBADLMT - 1/0 if report output should be delimitted
+20 ; Delimitted Output (1) or Formatted Output (0)
+21 ;Output Write Report Details
DSPLYDTL(DVBACSRT,DVBACIEN,DVBAPEXMS,DVBASCRH,DVBADLMT) ;Display Sorted Detailed Report Info
+1 NEW DVBAREF,DVBACNME,DVBARIEN,DVBAINFO,DVBAOFST
+2 NEW DVBASPCG,DVBALNE,DFN,VADM,X
+3 DO DRPTSPCG(DVBACSRT,DVBADLMT,.DVBASPCG)
+4 SET DVBAREF=DVBASCRH
SET DVBAOFST=0
SET (DVBACNME,DVBARIEN)=""
+5 if ('DVBACSRT)
SET DVBAOFST=1
+6 ;Quit if no results found
+7 if ('$DATA(@DVBASCRH))
QUIT
+8 ;Report Column Header Info
+9 if ((DVBACIEN']"")&(DVBACSRT))
WRITE "Contractor",$SELECT(DVBADLMT:"^",1:"")
+10 if ((DVBACIEN']"")&(DVBACSRT)&('DVBADLMT))
WRITE !
+11 WRITE ?DVBASPCG(1),"Request Date",$SELECT(DVBADLMT:"^",1:""),?DVBASPCG(2),"SSN",$SELECT(DVBADLMT:"^",1:"")
+12 WRITE ?DVBASPCG(3),"Patient Name",$SELECT(DVBADLMT:"^",1:""),?DVBASPCG(4),"Status",$SELECT(DVBADLMT:"^",1:"")
+13 if ('DVBADLMT)
WRITE !
+14 WRITE ?DVBASPCG(5),"Examinations",$SELECT(DVBADLMT:"^",1:"")
+15 if (('DVBACSRT)&(DVBACIEN']""))
WRITE ?DVBASPCG(6),"Contractor",$SELECT(DVBADLMT:"^",1:"")
+16 WRITE ?DVBASPCG(7),"Referred"
+17 SET DVBALNE=(DVBASPCG(7)+18)
+18 if ('DVBAPEXMS)
Begin DoDot:1
+19 WRITE ?DVBASPCG(8),$SELECT(DVBADLMT:"^",1:""),"Received"
+20 SET DVBALNE=(DVBASPCG(8)+12)
End DoDot:1
+21 ;Header Line
SET X=""
SET $PIECE(X,"-",DVBALNE)="-"
if ('DVBADLMT)
WRITE !,X
+22 FOR
SET DVBAREF=$QUERY(@DVBAREF)
if (DVBAREF'[$PIECE(DVBASCRH,")"))
QUIT
Begin DoDot:1
+23 ;Display Contractor Name, if NOT specific contractor report
+24 ; Delimitted Output
if ((DVBACIEN']"")&(DVBACSRT)&(DVBADLMT))
Begin DoDot:2
+25 WRITE !,@DVBAREF_"^"
End DoDot:2
+26 ;Formatted Output
if ((DVBACNME'=@DVBAREF)&(DVBACIEN']"")&(DVBACSRT)&('DVBADLMT))
Begin DoDot:2
+27 ;Extra Line Space between Contractors
if (DVBACNME]"")
WRITE !
+28 SET DVBACNME=@DVBAREF
+29 WRITE !,DVBACNME
End DoDot:2
+30 ;Display Request Info (Multiple Exams)
+31 if (DVBARIEN'=$PIECE(DVBAREF,",",(5-DVBAOFST)))
Begin DoDot:2
+32 SET DVBARIEN=$PIECE(DVBAREF,",",(5-DVBAOFST))
+33 ; Patient
SET DFN=+$GET(^DVB(396.3,DVBARIEN,0))
+34 ;DBIA: 10061
DO DEM^VADPT
+35 DO GETS^DIQ(396.3,DVBARIEN_",","17","E","DVBAINFO")
+36 ;Formatted Report
if ('DVBADLMT)
Begin DoDot:3
+37 ;No Seconds
WRITE !?DVBASPCG(1),$$FMTE^XLFDT($PIECE(DVBAREF,",",(4-DVBAOFST)),"M")
+38 WRITE ?DVBASPCG(2),$PIECE($GET(VADM(2)),"^",2),?DVBASPCG(3),$GET(VADM(1))
+39 WRITE ?DVBASPCG(4),$GET(DVBAINFO(396.3,DVBARIEN_",",17,"E"))
End DoDot:3
End DoDot:2
+40 ;Detailed Report
if (DVBADLMT)
Begin DoDot:2
+41 if '((DVBACIEN']"")&(DVBACSRT))
WRITE !
+42 ;No Seconds
WRITE $$FMTE^XLFDT($PIECE(DVBAREF,",",(4-DVBAOFST)),"M")_"^"
+43 WRITE $PIECE($GET(VADM(2)),"^",2)_"^"_$GET(VADM(1))_"^"
+44 WRITE $GET(DVBAINFO(396.3,DVBARIEN_",",17,"E"))_"^"
End DoDot:2
+45 ;Exam Info for Request
+46 DO EXMINFO(DVBAPEXMS,+$PIECE(DVBAREF,",",(7-DVBAOFST)),DVBACSRT,DVBADLMT,.DVBASPCG)
End DoDot:1
+47 KILL DVBAINFO,VADM
+48 QUIT
+49 ;
+50 ;Input DVBAPEXMS - 1/0 Indicates if only pending exams report
+51 ; DVBAEIEN - IEN of Exam (396.4)
+52 ; DVBACSRT - 1/0 if report should be sorted by Contractor
+53 ; Name (1) or by Request Date (0)
+54 ; DVBADLMT - 1/0 if report output should be delimitted
+55 ; Delimitted Output (1) or Formatted Output (0)
+56 ; DVBASPCG - Array to store spacing (By Ref)
+57 ;Output Write EXAM Info for request to report
EXMINFO(DVBAPEXMS,DVBAEIEN,DVBACSRT,DVBADLMT,DVBASPCG) ;Display Exam Info
+1 NEW DVBAEXM
+2 ;Retrieve exam info for display on report
+3 DO GETS^DIQ(396.4,DVBAEIEN_",",".03;100;101;102","EI","DVBAEXM")
+4 if ('DVBADLMT)
WRITE !
+5 WRITE ?DVBASPCG(5),$GET(DVBAEXM(396.4,DVBAEIEN_",",.03,"E")),$SELECT(DVBADLMT:"^",1:"")
+6 if ('DVBACSRT)
WRITE ?DVBASPCG(6),$GET(DVBAEXM(396.4,DVBAEIEN_",",100,"E")),$SELECT(DVBADLMT:"^",1:"")
+7 WRITE ?DVBASPCG(7),$$FMTE^XLFDT($PIECE($GET(DVBAEXM(396.4,DVBAEIEN_",",101,"I")),"@"),"M"),$SELECT(DVBADLMT:"^",1:"")
+8 if ('DVBAPEXMS)
WRITE ?DVBASPCG(8),$PIECE($GET(DVBAEXM(396.4,DVBAEIEN_",",102,"E")),"@")
+9 QUIT
+10 ;
+11 ;Input DVBACSRT - 1/0 if report should be sorted by Contractor
+12 ; Name (1) or by Request Date (0)
+13 ; DVBADLMT - 1/0 if report output should be delimitted
+14 ; Delimitted Output (1) or Formatted Output (0)
+15 ; DVBASPCG - Array to store spacing (By Ref)
DRPTSPCG(DVBACSRT,DVBADLMT,DVBASPCG) ;Setup Detailed Report Spacing
+1 NEW DVBAOFST,DVBAI
+2 SET DVBAOFST=0
if ('DVBACSRT&'DVBADLMT)
SET DVBAOFST=3
+3 KILL DVBASPCG
+4 if (DVBADLMT)
Begin DoDot:1
+5 FOR DVBAI=1:1:8
SET DVBASPCG(DVBAI)=0
End DoDot:1
+6 if ('DVBADLMT)
Begin DoDot:1
+7 SET DVBASPCG(1)=3-DVBAOFST
SET DVBASPCG(2)=23-DVBAOFST
+8 SET DVBASPCG(3)=36-DVBAOFST
SET DVBASPCG(4)=68-DVBAOFST
+9 SET DVBASPCG(5)=5-DVBAOFST
SET DVBASPCG(6)=70-DVBAOFST
+10 if (DVBACSRT)
SET DVBASPCG(7)=70-DVBAOFST
SET DVBASPCG(8)=91-DVBAOFST
+11 if ('DVBACSRT)
SET DVBASPCG(7)=101
SET DVBASPCG(8)=121
End DoDot:1
+12 QUIT
+13 ;
+14 ;Input DVBARIEN - IEN of Request (396.3) associated with Exam
+15 ; DVBACNDE - CNTRCTR Node for Exam IEN in 396.4
+16 ; DVBAGLBL - Global Reference for Requests Counted
+17 ; DVBARSLTS - Global Reference for results
+18 ;Output Global Array Entries Updated for Contractor if applicable
+19 ; ^TMP($J,"DVBATRPTS") / ^TMP("DVBATRSLTS",$J)
SRPTS(DVBARIEN,DVBACNDE,DVBAGLBL,DVBARSLTS) ;Summary Report Processing
+1 NEW DVBACNTR,DVBACNME
+2 SET DVBACNME=$PIECE($GET(^DVB(396.45,+$PIECE(DVBACNDE,"^"),0)),"^")
+3 ;Retrieve current number of exams referred by contractor
+4 SET DVBACNTR=$PIECE($GET(@DVBARSLTS@(DVBACNME,+$PIECE(DVBACNDE,"^"))),"^",3)
+5 ;Increment Number of Exams referred for contractor
+6 SET $PIECE(@DVBARSLTS@(DVBACNME,+$PIECE(DVBACNDE,"^")),"^",3)=DVBACNTR+1
+7 ;Increment 2507 Request Counter if IEN NOT already counted for Contractor
+8 if ('$DATA(@DVBAGLBL@(+$PIECE(DVBACNDE,"^"),DVBARIEN)))
Begin DoDot:1
+9 ;Add request IEN to list
SET @DVBAGLBL@(+$PIECE(DVBACNDE,"^"),DVBARIEN)=""
+10 SET DVBACNTR=$PIECE($GET(@DVBARSLTS@(DVBACNME,+$PIECE(DVBACNDE,"^"))),"^",4)
+11 ;Increment # of 2507 Request referred to contractor
+12 SET $PIECE(@DVBARSLTS@(DVBACNME,+$PIECE(DVBACNDE,"^")),"^",4)=DVBACNTR+1
End DoDot:1
+13 QUIT
+14 ;
+15 ;Input DVBACNDE - CNTRCTR Node for Exam IEN in 396.4
+16 ; DVBAGLBL - Global Reference for Timeliness counters
+17 ; DVBARSLTS - Global Reference for results
+18 ;Output Global Array Entries Updated for Contractor if applicable
+19 ; ^TMP($J,"DVBATRPTS") / ^TMP("DVBATRSLTS",$J)
TRPTS(DVBACNDE,DVBAGLBL,DVBARSLTS,DVBATVAL) ;Timeliness Report Processing
+1 NEW DVBACNME,DVBANDAYS,DVBANEXMS
+2 ;Ignore Exams NOT returned (Checked-In) by Contractor
+3 SET DVBANDAYS=+$GET(@DVBAGLBL@(+$PIECE(DVBACNDE,"^"),"DAYS"))
+4 SET DVBANEXMS=+$GET(@DVBAGLBL@(+$PIECE(DVBACNDE,"^"),"EXMS"))
+5 ;Increment Timeliness Counter (Total # of Days)
+6 SET @DVBAGLBL@(+$PIECE(DVBACNDE,"^"),"DAYS")=DVBANDAYS+DVBATVAL
+7 ;Increment Number of Exams Found
+8 SET @DVBAGLBL@(+$PIECE(DVBACNDE,"^"),"EXMS")=DVBANEXMS+1
+9 SET DVBACNME=$PIECE($GET(^DVB(396.45,+$PIECE(DVBACNDE,"^"),0)),"^")
+10 ;Update Average Timeliness result for Contractor
+11 SET $PIECE(@DVBARSLTS@(DVBACNME,+$PIECE(DVBACNDE,"^")),"^",3)=$FNUMBER((DVBANDAYS+DVBATVAL)/(DVBANEXMS+1),"",0)
+12 QUIT
+13 ;
TRPTS2(DVBACNDE) ;Timeliness include logic
+1 NEW DVBACNME,DVBATVAL,DVBANDAYS,DVBANEXMS,X1,X2,X,%Y
+2 NEW DVBAEXM2,STAT
+3 KILL ^TMP($JOB,"DVBACER1.FLAG")
+4 DO GETS^DIQ(396.4,DVBAEIEN_",",".03;.04;100;101;102","EI","DVBAEXM2")
+5 SET STAT=$GET(DVBAEXM2(396.4,DVBAEIEN_",",.04,"I"))
+6 SET CNTR=$GET(DVBAEXM2(396.4,DVBAEIEN_",",100,"I"))
if $GET(CNTR)=""
SET CNTR="X"
+7 SET X1=$PIECE(DVBACNDE,"^",3)
SET X2=$PIECE(DVBACNDE,"^",2)
DO ^%DTC
+8 IF $PIECE(DVBACNDE,"^",3)=""
SET ^TMP($JOB,"DVBACER1.FLAG",CNTR)=1
+9 ;# Days between CheckIn and CheckOut
SET DVBATVAL=X
+10 if DVBATVAL=""
SET DVBATVAL=0
+11 SET ^TMP($JOB,"DVBACER1",CNTR,DVBATVAL)=DVBACNDE_"|"_STAT
+12 QUIT
+13 ;
TRPTS3(DVBAGLBL,DVBARSLTS) ;Timeliness calculation section
+1 if '$DATA(^TMP($JOB,"DVBACER1"))
QUIT
+2 NEW OPENEXM,CNTR,DVBATVAL
+3 SET CNTR=""
FOR
SET CNTR=$ORDER(^TMP($JOB,"DVBACER1",CNTR))
if CNTR=""
QUIT
Begin DoDot:1
+4 if CNTR="X"
QUIT
+5 if $GET(^TMP($JOB,"DVBACER1.FLAG",CNTR))=1
QUIT
+6 SET OPENEXM(CNTR)=0
+7 SET DVBATVAL=""
FOR
SET DVBATVAL=$ORDER(^TMP($JOB,"DVBACER1",CNTR,DVBATVAL))
if DVBATVAL=""!(OPENEXM(CNTR)=1)
QUIT
Begin DoDot:2
+8 IF $PIECE(^TMP($JOB,"DVBACER1",CNTR,DVBATVAL),"|",2)'="C"
SET OPENEXM(CNTR)=1
QUIT
End DoDot:2
End DoDot:1
+9 SET CNTR=""
FOR
SET CNTR=$ORDER(OPENEXM(CNTR))
if CNTR=""
QUIT
Begin DoDot:1
+10 if OPENEXM(CNTR)=1
QUIT
+11 SET DVBATVAL=$ORDER(^TMP($JOB,"DVBACER1",CNTR,""),-1)
SET DVBACNDE=$PIECE(^TMP($JOB,"DVBACER1",CNTR,DVBATVAL),"|",1)
Begin DoDot:2
+12 if DVBATVAL=0
QUIT
+13 DO TRPTS(DVBACNDE,DVBAGLBL,DVBARSLTS,DVBATVAL)
End DoDot:2
End DoDot:1
+14 KILL ^TMP($JOB,"DVBACER1")
+15 KILL ^TMP($JOB,"DVBACER1.FLAG")
+16 ;
GETHFS() ;Get HFS File Name
+1 NEW DVBAH
+2 SET DVBAH=$HOROLOG
+3 QUIT "DVBA_"_$JOB_"_"_$PIECE(DVBAH,",")_"_"_$PIECE(DVBAH,",",2)_".DAT"
+4 ;
OPENHFS(DVBAHNDL,DVBAHFS,DVBAMODE,DVBARSLTS) ;Open HFS File
+1 NEW DVBAERR,POP
+2 SET DVBAERR=0
+3 DO OPEN^%ZISH(DVBAHNDL,,DVBAHFS,$GET(DVBAMODE,"W"))
if POP
Begin DoDot:1
+4 SET DVBAERR=1
SET @DVBARSLTS@(1)="0^Unable to open HFS file."
End DoDot:1
if POP
QUIT
+5 QUIT DVBAERR
+6 ;
CLOSEHFS(DVBAHNDL,DVBAHFS,DVBARSLTS) ;Close HFS and unload data
+1 NEW DVBADEL,X,%ZIS
+2 DO CLOSE^%ZISH(DVBAHNDL)
+3 SET DVBADEL(DVBAHFS)=""
+4 SET X=$$FTG^%ZISH(,DVBAHFS,$NAME(@DVBARSLTS@(1)),4)
+5 SET X=$$DEL^%ZISH(,$NAME(DVBADEL))
+6 QUIT
+7 ;
