DVBAB82 ;ALB/DJS - CAPRI DVBA REPORTS ; 01/24/12
;;2.7;AMIE;**42,90,100,119,156,149,179,181,184,185,192,196,193,252**;Apr 10, 1995;Build 92
;Per VHA Directive 2004-038, this routine should not be modified.
;Reference to PRNT^SROESPR in ICR #1203
;Reference to File 133 ^SRO(133) in ICR #2237
;ALB/RTW added subroutine VBACRPON to allow VBA reprint reagrdless of office
Q
;
START(MSG,RPID,PARM) ; CALLED BY REMOTE PROCEDURE DVBAB REPORTS
;Parameters
;=============
; MSG : Output - ^TMP("DVBA",$J)
; RPID : Report Identification Number
; PARM : Input parameters separated by "^"
;
N DVBHFS,DVBERR,DVBGUI,I,DVBADLMTD
K ^TMP("DVBA",$J)
S DVBGUI=1,(DVBERR,DVBADLMTD)=0,DVBHFS=$$HFS(),RPID=$G(RPID)
I RPID<1!(RPID>15) S DVBERR=1,^TMP("DVBA",$J,1)="0^Undefined Report ID" G END
D HFSOPEN("DVBRP",DVBHFS,"W") I DVBERR G END
I RPID=1 D CRMS G END
I RPID=3 D CPRNT G END
I RPID=11 D CNHRP G END ;FNCNH Print Roster
D CHECK I DVBERR G END ;reports below require parameters
I RPID=2 D CRRR G END
I RPID=4 D CRPON G END
;DVBA*196 - I6184115FY16 REMOVE CALL TO VBACRPON
;I RPID=4,$P(PARM,U,8)=0 D CRPON G END
;I RPID=4,$P(PARM,U,8)=1 D VBACRPON G END
I RPID=5 D CIRPT G END
I RPID=6 D DSRP G END
I RPID=7 D SDPP G END
I RPID=8 D SPRPT G END
I RPID=9 D VIEW G END
I RPID=10 D CNHDEOC G END ;FBCNH Display Episode Of Care
I RPID=12 D CNHRAD G END ;FNCNH Report of Admissions/Discharges
I RPID=13 D CNHSE90D G END ;FNCNH Stays in Excess of 90 Days
I RPID=14 D REQSTAT G END ;REQUEST STATUS BY DATE RANGE
I RPID=15 D DVBA8861 G END ;FORM 28-8861 STATUS REPORT
;
END D HFSCLOSE("DVBRP",DVBHFS)
I ($G(DVBADLMTD)&('+DVBERR)) D Q ;Create delimited output if no errors
.D DLMTRPT^DVBAB82D(RPID)
.S I=0 F S I=$O(^TMP("DVBADLMTD",$J,I)) Q:I="" D
..I $G(^TMP("DVBADLMTD",$J,I))["##FFFF##" S ^TMP("DVBADLMTD",$J,I)=$TR(^TMP("DVBADLMTD",$J,I),"##FFFF##","")
.S MSG=$NA(^TMP("DVBADLMTD",$J))
;Replace "##FFFF##" with Form Feeds - code needed for LINUX environments
S I=0 F S I=$O(^TMP("DVBA",$J,1,I)) Q:'I D
.S:^TMP("DVBA",$J,1,I)["##FFFF##" ^TMP("DVBA",$J,1,I)=$P(^TMP("DVBA",$J,1,I),"##FFFF##")_$C(13,12)_$P(^TMP("DVBA",$J,1,I),"##FFFF##",2)
.S ^TMP("DVBA",$J,1,I)=^TMP("DVBA",$J,1,I)_$C(13)
.S:^TMP("DVBA",$J,1,I)["$END" ^TMP("DVBA",$J,1,I)=""
S MSG=$NA(^TMP("DVBA",$J))
I ($G(RPID)=5)&($G(DVBADLMTR)=",") S MSG=$NA(^TMP("INSUFF",$J))
Q
CHECK ; VALIDATE INPUT PARAMETERS
I $G(PARM)="" S DVBERR=1,^TMP("DVBA",$J,1)="0^Undefined Input Parameters"
Q
;
SDPP ; Report # 7 - Full (Patient Profile MAS) Report
;Parameters
;=============
; DFN : Patient Identification Number
; SDR : R/Range or A/All
; SDBD : Begining date
; SDED : Ending date
; SDP : Print the profile? 1 OR 0
; SDTYP(2) : Print appointments? 1 OR 0
; SDTYP(1) : Print add/edits? 1 or 0
; SDTYP(4) : Print enrollments? 1 or 0
; SDTYP(3) : Print dispositions? 1 OR 0
; SDTYP(7) : Print team information? 1 OR 0
; SDTYP(5) : Print means test? 1 OR 0
;
N SDTYP,SDBD,SDED,SDACT,SDPRINT,SDYES,SDRANGE,SDBEG,SDEN
S ^XTMP("JAP",$J,$$NOW^XLFDT(),"SDPP")=PARM
S DFN=$P(PARM,"^",1),SDR=$P(PARM,"^",2),SDBD=$P(PARM,"^",3),SDED=$P(PARM,"^",4)
S SDP=$P(PARM,"^",5),SDTYP(2)=$P(PARM,"^",6),SDTYP(1)=$P(PARM,"^",7)
S SDTYP(4)=$P(PARM,"^",8),SDTYP(3)=$P(PARM,"^",9),SDTYP(7)=$P(PARM,"^",10),SDTYP(5)=$P(PARM,"^",11)
D VAL Q:DVBERR
S SDACT="",(SDYES,SDRANGE,SDPRINT)=0
I SDR="R" S SDRANGE=1
I SDP=1 S SDYES=1,SDPRINT=1
I 'SDRANGE S (SDBD,SDBEG)=2800101,(SDED,SDEND)=$$ENDDT(),SDHDR=1
D ENS^%ZISS
S SDPRINT=1
S:(SDTYP(2)=1) SDTYP(2)="" ;appointments
K:(SDTYP(2)=0) SDTYP(2)
S:(SDTYP(1)=1) SDTYP(1)="" ;add/edits
K:(SDTYP(1)=0) SDTYP(1)
I (SDTYP(4)=1) S SDTYP(4)="",SDACT=0 ;enrollments
K:(SDTYP(4)=0) SDTYP(4)
S:(SDTYP(3)=1) SDTYP(3)="" ;dispositions
K:(SDTYP(3)=0) SDTYP(3)
S:(SDTYP(5)=1) SDTYP(5)="" ;means test
K:(SDTYP(5)=0) SDTYP(5)
I SDTYP(7)=1 D ;team information
. S SDTYP(7)="",GBL="^TMP(""SDPP"","_$J_")"
K:(SDTYP(7)=0) SDTYP(7)
D PRINT^SDPPRT
S VALMBCK="R"
Q
ENDDT() ;Calculate end date for "all" date
N DVBAPPTS,DVBX
S DVBAPPTS(1)=2800101,DVBAPPTS(4)=DFN,DVBAPPTS("SORT")="P"
S DVBAPPTS("FLDS")=1,DVBAPPTS("MAX")=-1
S DVBX=$S(($$SDAPI^SDAMA301(.DVBAPPTS)>0):$O(^TMP($J,"SDAMA301",DFN,0)),1:DT_.24)
K ^TMP($J,"SDAMA301")
Q DVBX
;
VIEW ; Report # 9 - View Registration Data Report
; Parameters
; ==========
; DFN : Patient Identification Number
;
U IO
S DFN=$P(PARM,"^",1)
D VAL Q:DVBERR
D EN1^DGRP
Q
;
DSRP ; Report # 6 - Reprint a Notice of Discharge Report
; Parameters
; % : 1=Report on all veterans for a given day (BDATE required)
; : 0=Report on a single Veteran (DFN required)
; BDATE : Original Processing Date - $H/FileMan
; DFN : Patient Identification Number
;
N %,BDATE,DFN,DFNIEN
S %=$P(PARM,"^",1),BDATE=$P(PARM,"^",2),DFN=$P(PARM,"^",3),DFNIEN=""
I BDATE="" S DVBERR=1,^TMP("DVBA",$J,1)="0^Incorrect Date" Q
D DUZ2^DVBAUTIL
U IO
D VAL Q:DVBERR
I %=1 D Q
. S HD="SINGLE NOTICE OF DISCHARGE REPRINTING"
. D NOPARM^DVBAUTL2
. I $D(DVBAQUIT) D KILL^DVBAUTIL Q ;CAUTION: Short-circuit
. S DTAR=^DVB(396.1,1,0),FDT(0)=$$FMTE^XLFDT(DT,"5DZ")
. S HEAD="NOTICE OF DISCHARGE",HEAD1="FOR "_$P(DTAR,U,1)_" ON "_FDT(0)
. I $D(^DVB(396.2,"B",DFN)) D
. . S DFNIEN=$O(^DVB(396.2,"B",DFN,DFNIEN)),ADM=$P(^DVB(396.2,DFNIEN,0),U,3)
. . I $D(^DGPM(+ADM,0)),$P(^(0),U,17)]"" S DCHPTR=$P(^DGPM(+ADM,0),U,17),DISCH=$S($P(^DGPM(DCHPTR,0),U,1)]"":$P(^(0),U,1),1:"") W ?($X+5),"Discharge date: ",$$FMTE^XLFDT(DISCH,"5DZ")
. . I $P(^DVB(396.2,DFNIEN,0),U,7)'=DVBAD2 W *7,!!,"This does not belong to your RO.",!! H 3 Q
. . I DFNIEN>0 S XDA=DFNIEN,DA=$P(^DVB(396.2,DFNIEN,0),U,1),ADMDT=$P(^DVB(396.2,DFNIEN,0),U,2),MB=$P(^(0),U,3)
. . D REPRINT^DVBADSNT
D DEQUE^DVBADSRP
Q
;
SPRPT ; Report # 8 - OP(Operation Report)
;Parameters
;=============
; DFN : Patient Identification Number
; DVBRTN : Select Operation
;
;CAPRI-11150;JCS;06/27/2024
; Report re-write due to interference with RPC Broker
;
N DFN,DVBRTN,DVBSITE,DVBSINED,DVBSTAT,DVBDTITL,DVBTIU
I $O(^SRO(133,1))'="B" S DVBSITE=1
S DFN=$P(PARM,"^",1),DVBRTN=$P(PARM,"^",2)
D VAL Q:DVBERR
S DVBSINED=0,DVBSTAT="",DVBTIU=$P($G(^SRF(DVBRTN,"TIU")),"^")
I $G(DVBTIU) S DVBSTAT=$$STATUS^SROESUTL(DVBTIU) S:DVBSTAT=7 DVBSINED=1
I $G(DVBSINED) S DVBTIU=$P($G(^SRF(DVBRTN,"TIU")),"^") I $G(DVBTIU) D PRNT^SROESPR(DVBRTN,DVBTIU,"Operation Report") Q
I 'DVBSINED W !!," * * The Operation Report for this case is not yet available. * *"
K ^TMP("SROP",$J),SRPARM,DVBDIRY
Q
;
CRPON ; Report # - 4 Reprint C&P Final Report
;Parameters
;=============
; RTYPE : Select Reprint Option (D)ate or (V)eteran
; RUNDATE : ORIGINAL PROCESSING date
; ANS : Reprinted by the RO or MAS
; % : LAB 1 OR 0
; DA(1) : Patient IEN for lab results
; DFN : Patient Identification Number
;
U IO
N ONE,DVBAQ,DVBAWHO
S DVBAWHO=$P($G(PARM),U,8),DVBAQ=""
S RTYPE=$P(PARM,"^",1),RUNDATE=$P(PARM,"^",2),ANS=$P(PARM,"^",3),%=$P(PARM,"^",4),DA(1)=$P(PARM,"^",5),DFN=$P(PARM,"^",6),DA=DA(1)
I RTYPE="V" D VAL Q:DVBERR
S XDD=^DD("DD"),$P(ULINE,"_",70)="_",ONE="N",Y=DT
X XDD S HD="Reprint C & P Exams",SUPER=0
I $D(^XUSEC("DVBA C SUPERVISOR",DUZ)) S SUPER=1
S DVBCDT(0)=Y,PGHD="Compensation and Pension Exam Report",LOC=DUZ(2),PG=0,DVBCSITE=$S($D(^DVB(396.1,1,0)):$P(^(0),U,1),1:"Not specified")
I "^D^V^"'[RTYPE S DVBERR=1,^TMP("DVBA",$J,1)="0^Incorrect Data Type" Q
I ANS="R" K AUTO
I ANS="M" S AUTO=1
I "^M^R^"'[ANS S DVBERR=1,^TMP("DVBA",$J,1)="0^Incorrect Data Type" Q
I RTYPE="D" D GO^DVBCRPRT Q
;DVBA*196 - I6184115FY16 FIX VALIDATION LOGIC FOR "BY VETERAN" TO MEET REQUIREMENTS IN PATCH 192
I RTYPE="V" D
. ;AJF;Request Status conversion
. S RQST=$$RSTAT^DVBCUTL8($P(^DVB(396.3,DA,0),U,18))
. S ONE="Y",RO=$P(^DVB(396.3,DA,0),U,3)
. I DVBAWHO=0 D
.. I RO'=DUZ(2)&('$D(AUTO))&(SUPER=0) W !!,*7,"Those results do not belong to your office.",!! S DVBAQ=1 Q
.. ;AJF;Request Status conversion
.. I RO=DUZ(2)&('$D(AUTO))&("RC"'[RQST) W *7,!!,"This request has not been released to the Regional Office yet.",!! S DVBAQ=1 Q
.. S PRTDATE=$P(^DVB(396.3,DA,0),U,16) I PRTDATE="" W *7,!!,"This has never been printed.",!! I SUPER=0 S OUT=1 S DVBAQ=1 Q
. I DVBAWHO=1 D
..;AJF;Request Status conversion
.. I "RC"'[RQST W *7,!!,"This request has not been released to the Regional Office yet.",!! S DVBAQ=1 Q
. I DVBAQ=1 Q
. I %=1 D REN2^DVBCLABR Q
. ;D OV^DVBCRPON
. K DVBAON2 D SETLAB^DVBCPRNT,VARS^DVBCUTIL D
..I DVBAWHO=1 D VBASTEP2^DVBCRPRT
..I DVBAWHO=0 D STEP2^DVBCRPRT
Q
;
VBACRPON ; Report # - 4 Reprint C&P Final Report by VBA personnel
;Parameters
;=============
; RTYPE : Select Reprint Option (D)ate or (V)eteran
; RUNDATE : ORIGINAL PROCESSING date
; ANS : Reprinted by the RO or MAS
; % : LAB 1 OR 0
; DA(1) : Patient IEN for lab results
; DFN : Patient Identification Number
;
S DVBERR=0
I $D(^TMP("DVBA",$J)) S DVBAX=(^TMP("DVBA",$J))
U IO
N ONE
S RTYPE=$P(PARM,"^",1),RUNDATE=$P(PARM,"^",2),ANS=$P(PARM,"^",3),%=$P(PARM,"^",4),DA(1)=$P(PARM,"^",5),DFN=$P(PARM,"^",6),DA=DA(1)
I RTYPE="V" D VAL Q:DVBERR
S XDD=^DD("DD"),$P(ULINE,"_",70)="_",ONE="N",Y=DT
X XDD S HD="Reprint C & P Exams"
S DVBCDT(0)=Y,PGHD="Compensation and Pension Exam Report",LOC=DUZ(2),PG=0,DVBCSITE=$S($D(^DVB(396.1,1,0)):$P(^(0),U,1),1:"Not specified")
I "^D^V^"'[RTYPE S DVBERR=1,^TMP("DVBA",$J,1)="0^Incorrect Data Type" Q
I ANS="R" K AUTO
I ANS="M" S AUTO=1
I "^M^R^"'[ANS S DVBERR=1,^TMP("DVBA",$J,1)="0^Incorrect Data Type" Q
I RTYPE="D" D VBAGO^DVBCRPRT Q
I RTYPE="V" D
. S ONE="Y",RO=$P(^DVB(396.3,DA,0),U,3)
. S PRTDATE=$P(^DVB(396.3,DA,0),U,16)
. I %=1 D REN2^DVBCLABR Q
. K DVBAON2 D SETLAB^DVBCPRNT,VARS^DVBCUTIL,VBASTEP2^DVBCRPRT
Q
;
CIRPT ; Report # 5 - Insufficient Exam Report
;Parameters
;=============
; RPTTYPE : D/Detailed or S/Summary
; BEGDT : Beginning date $H/FileMan
; ENDDT : Ending date $H/FileMan
; RESANS : Insufficient Reason
; DVBAPRTY : Priority of Exam Code
; AO : Agent Orange
; BDD : Benefits Delivery at Discharge / Quick Start
; IDES : Integrated Disability Evaluation System
; ALL : All Others (Original Report w/ all codes except the above)
; DVBADLMTR: 0=non-delimited format, ","=delimiter for .csv file for EXCEL
;
N DVBAPRTY,RPTTYPE,BEGDT,ENDDT,RESANS
U IO
S RPTTYPE=$P(PARM,"^",1),BEGDT=$P(PARM,"^",2),ENDDT=$P(PARM,"^",3),RESANS=""
S DVBADLMTR=$P(PARM,"^",6),DVBADLMTR=$S(DVBADLMTR=1:",",1:0)
S ENDDT=ENDDT_".2359"
I RPTTYPE="S" D SUM^DVBCIRP2 Q
I RPTTYPE="D" D
. D INREAS
. Q:($D(^TMP("DVBA",$J,1))) ;invalid reason sent
. D EXMTPE,DETAIL^DVBCIRP2
Q
;
EXMTPE ;exam types (retrieve all for filter)
N DVBAXIFN
F DVBAXIFN=0:0 S DVBAXIFN=$O(^DVB(396.6,DVBAXIFN)) Q:+DVBAXIFN=0 DO
. S ^TMP($J,"XMTYPE",DVBAXIFN)=""
Q
INREAS ;insufficient reason (validate specific or retrieve all)
N DVBAXIFN
D:(RESANS="") ;use all insufficient reasons
.F DVBAXIFN=0:0 S DVBAXIFN=$O(^DVB(396.94,DVBAXIFN)) Q:+DVBAXIFN=0 DO
.. S DVBAARY("REASON",DVBAXIFN)=""
;D:(RESANS'="") ;use specific insufficient reason
;.I ('$D(^DVB(396.94,+RESANS))) D ;validate IEN
;..S DVBERR=1,^TMP("DVBA",$J,1)="0^Invalid Insufficient Reason IEN"
;.E S DVBAARY("REASON",+RESANS)=""
Q
;
CRMS ; Report # 1 - Regional Office 21- day Certificate Printing Report.
; No Parameters
;
U IO
D ^DVBACRMS
Q
;
CRRR ; Report # 2 - Reprint a 21 - day Certificate for the RO
;Parameters
;=============
; DVBSEL : Select one of the following:
; N Patient Name
; D ORIGINAL PROCESSING DATE
; SDATE : ORIGINAL PROCESSING date - $H/FileMan
; XDA : Patient IEN
;
U IO
S DVBSEL=$P(PARM,"^",1),SDATE=$P(PARM,"^",2),XDA=$P(PARM,"^",3)
I "^D^N^"'[DVBSEL S DVBERR=1,^TMP("DVBA",$J,1)="0^Incorrect Data Type" Q
I DVBSEL="D" D I DVBERR Q
. I SDATE="" S DVBERR=1,^TMP("DVBA",$J,1)="0^Undefined Date" Q
. S %DT="X" S X=SDATE D ^%DT I Y<0 D Q
. . S DVBERR=1,^TMP("DVBA",$J,1)="0^Incorrect Date Format"
I DVBSEL="N" D I DVBERR Q
. I XDA="" S DVBERR=1,^TMP("DVBA",$J,1)="0^Undefined Patient IEN" Q
. S DIC=2,DIC(0)="NZX",X=XDA D ^DIC I Y<0 D I DVBERR Q
. . S DVBERR=1,^TMP("DVBA",$J,1)="0^Invalid Patient Name."
. S DFN=XDA
D INIT^DVBACRRR I 'CONT Q
D HDR^DVBACRRR,DATA^DVBACRRR
Q
;
CPRNT ; Report # 3 - Print C&P Final Report (manual) Report
; No Parameters
;
S XDD=^DD("DD"),$P(ULINE,"_",70)="_",Y=DT
X XDD S DVBCDT(0)=Y,PGHD="Compensation and Pension Exam Report",DVBCSITE=$S($D(^DVB(396.1,1,0)):$P(^(0),U,1),1:"Not Specified")
D GO^DVBCPRNT
Q
VAL ; VALIDATE PATIENT
I $G(DFN)="" S DVBERR=1,^TMP("DVBA",$J,1)="0^Undefined Patient IEN" G END
S DIC=2,DIC(0)="NZX",X=DFN D ^DIC
I Y<0 S DVBERR=1,^TMP("DVBA",$J,1)="0^Invalid Patient Name." G END
Q
;
VALDATE(DVBADTE) ;Validate Date
;dates must be valid internal FileMan format
N X,Y,%DT
S %DT="X",X=DVBADTE D ^%DT
S:(Y=-1) DVBERR=1,^TMP("DVBA",$J,1)="0^Invalid FileMan formatted date."
Q
;
CNHDEOC ; Report #10 - FBCNH Display Episode of Care
; Parameters
; ==========
; DFN : IEN in PATIENT (#2) file
; IFN : IEN in FEE CNH ACTIVITY (#162.3) file
;
U IO
N DFN,IFN
S DFN=$P(PARM,U,1),IFN=$P(PARM,U,2)
D ^FBNHDEC ;DBIA#: 5566
Q
;
CNHRP ; Report #11 - FBCNH Roster Print
; Parameters
; ==========
; DVBADLMTD : 0 (Standard) or 1 (Delimited)
;
U IO
S DVBADLMTD=+$P($G(PARM),U)
D START^FBNHROS ;DBIA#: 5566
Q
;
CNHRAD ; Report #12 - FBCNH Report of Admissions/Discharges
; Parameters
; ==========
; BEGDATE : Start date in FM format
; ENDDATE : End date in FM format
; DVBADLMTD : 0 (Standard) or 1 (Delimited)
;
U IO
N BEGDATE,ENDDATE
S BEGDATE=$P(PARM,U,1),ENDDATE=$P(PARM,U,2)
S DVBADLMTD=+$P(PARM,U,3)
D VALDATE(BEGDATE),VALDATE(ENDDATE)
D:('+DVBERR) START^FBNHAMIE ;DBIA#: 5566
Q
;
CNHSE90D ; Report #13 - FBCNH Stays in Excess of 90 Days
; Parameters
; ==========
; FBDT : Effective date in FM format
; DVBADLMTD : 0 (Standard) or 1 (Delimited)
;
U IO
N FBDT
S FBDT=$P(PARM,U,1),DVBADLMTD=+$P(PARM,U,2)
D VALDATE(FBDT)
D:('+DVBERR) START^FBNHAMI2 ;DBIA#: 5566
Q
;
HFS() ; -- get hfs file name
N H
S H=$H
Q "DVBA_"_$J_"_"_$P(H,",")_"_"_$P(H,",",2)_".DAT"
;
HFSOPEN(HANDLE,DVBHFS,DVBMODE) ; Open File
S DVBDIRY=$$GET^XPAR("DIV","DVB HFS SCRATCH")
;I DVBDIRY="" S ECERR=1 D Q
;. S ^TMP("DVBA",$J,1)="0^A scratch directory for reports doesn't exist"
D OPEN^%ZISH(HANDLE,,DVBHFS,$G(DVBMODE,"W")) D:POP Q:POP
.S DVBERR=1,^TMP("DVBA",$J,1)="0^Unable to open file "
S IOF="$$IOF^DVBAB82" ;resets screen position and adds page break flag - added to deal with Linux environments.
Q
;
HFSCLOSE(HANDLE,DVBHFS) ;Close HFS and unload data
N DVBDEL,X,%ZIS
D CLOSE^%ZISH(HANDLE)
S DVBDEL(DVBHFS)=""
S ROOT=$NA(^TMP("DVBA",$J,1))
K:('+DVBERR) @ROOT
S X=$$FTG^%ZISH(,DVBHFS,$NA(@ROOT@(1)),4)
S X=$$DEL^%ZISH(,$NA(DVBDEL))
Q
;
IOF() ;used to reset position and insert page break flag when @IOF is executed.
S $X=0,$Y=0
Q "##FFFF##"_$C(13,10)
;
REQSTAT ; Report #14 - Request Status by Date Range
; Parameters
; ==========
; BEGDAT : Start date in FM format
; ENDDAT : End date in FM format
; REQSTAT : Request Status filter
; ISDELIM : 0 (Standard format); 1 (Delimited format)
; ISNODT : 0 (Use date range); 1 (Ignore date range)
U IO
N BEGDAT,ENDDAT,REQSTAT
S BEGDAT=$P(PARM,U,1),ENDDAT=$P(PARM,U,2)
S REQSTAT=$P(PARM,U,3),ISDELIM=$P(PARM,U,4),ISNODT=$P(PARM,U,5)
D VALDATE(BEGDAT),VALDATE(ENDDAT)
D:('+DVBERR) REQSTAT^DVBARSBD(BEGDAT,ENDDAT,REQSTAT,ISDELIM,ISNODT)
Q
;
DVBA8861 ; Report #15 - Form 28-8861 Status Report
; Parameters
; ==========
; BEGDAT - Start date in FM format
; ENDDAT - End date in FM format
; ROSTAT - Regional Office filter
; REQSTAT - Request Status filter
; DELIMTER - 0 (Standard format); 1 (Delimited format)
;
U IO
N BEGDAT,ENDDAT,REQSTAT
S BEGDAT=$P(PARM,U,1),ENDDAT=$P(PARM,U,2)
S ROSTAT=$P(PARM,U,3),REQSTAT=$P(PARM,U,4),DELIMTER=$P(PARM,U,5)
D VALDATE(BEGDAT),VALDATE(ENDDAT)
D:('+DVBERR) STATRPT^DVBA8861(BEGDAT,ENDDAT,ROSTAT,REQSTAT,DELIMTER)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBAB82 16513 printed Sep 23, 2025@19:16:36 Page 2
DVBAB82 ;ALB/DJS - CAPRI DVBA REPORTS ; 01/24/12
+1 ;;2.7;AMIE;**42,90,100,119,156,149,179,181,184,185,192,196,193,252**;Apr 10, 1995;Build 92
+2 ;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;Reference to PRNT^SROESPR in ICR #1203
+4 ;Reference to File 133 ^SRO(133) in ICR #2237
+5 ;ALB/RTW added subroutine VBACRPON to allow VBA reprint reagrdless of office
+6 QUIT
+7 ;
START(MSG,RPID,PARM) ; CALLED BY REMOTE PROCEDURE DVBAB REPORTS
+1 ;Parameters
+2 ;=============
+3 ; MSG : Output - ^TMP("DVBA",$J)
+4 ; RPID : Report Identification Number
+5 ; PARM : Input parameters separated by "^"
+6 ;
+7 NEW DVBHFS,DVBERR,DVBGUI,I,DVBADLMTD
+8 KILL ^TMP("DVBA",$JOB)
+9 SET DVBGUI=1
SET (DVBERR,DVBADLMTD)=0
SET DVBHFS=$$HFS()
SET RPID=$GET(RPID)
+10 IF RPID<1!(RPID>15)
SET DVBERR=1
SET ^TMP("DVBA",$JOB,1)="0^Undefined Report ID"
GOTO END
+11 DO HFSOPEN("DVBRP",DVBHFS,"W")
IF DVBERR
GOTO END
+12 IF RPID=1
DO CRMS
GOTO END
+13 IF RPID=3
DO CPRNT
GOTO END
+14 ;FNCNH Print Roster
IF RPID=11
DO CNHRP
GOTO END
+15 ;reports below require parameters
DO CHECK
IF DVBERR
GOTO END
+16 IF RPID=2
DO CRRR
GOTO END
+17 IF RPID=4
DO CRPON
GOTO END
+18 ;DVBA*196 - I6184115FY16 REMOVE CALL TO VBACRPON
+19 ;I RPID=4,$P(PARM,U,8)=0 D CRPON G END
+20 ;I RPID=4,$P(PARM,U,8)=1 D VBACRPON G END
+21 IF RPID=5
DO CIRPT
GOTO END
+22 IF RPID=6
DO DSRP
GOTO END
+23 IF RPID=7
DO SDPP
GOTO END
+24 IF RPID=8
DO SPRPT
GOTO END
+25 IF RPID=9
DO VIEW
GOTO END
+26 ;FBCNH Display Episode Of Care
IF RPID=10
DO CNHDEOC
GOTO END
+27 ;FNCNH Report of Admissions/Discharges
IF RPID=12
DO CNHRAD
GOTO END
+28 ;FNCNH Stays in Excess of 90 Days
IF RPID=13
DO CNHSE90D
GOTO END
+29 ;REQUEST STATUS BY DATE RANGE
IF RPID=14
DO REQSTAT
GOTO END
+30 ;FORM 28-8861 STATUS REPORT
IF RPID=15
DO DVBA8861
GOTO END
+31 ;
END DO HFSCLOSE("DVBRP",DVBHFS)
+1 ;Create delimited output if no errors
IF ($GET(DVBADLMTD)&('+DVBERR))
Begin DoDot:1
+2 DO DLMTRPT^DVBAB82D(RPID)
+3 SET I=0
FOR
SET I=$ORDER(^TMP("DVBADLMTD",$JOB,I))
if I=""
QUIT
Begin DoDot:2
+4 IF $GET(^TMP("DVBADLMTD",$JOB,I))["##FFFF##"
SET ^TMP("DVBADLMTD",$JOB,I)=$TRANSLATE(^TMP("DVBADLMTD",$JOB,I),"##FFFF##","")
End DoDot:2
+5 SET MSG=$NAME(^TMP("DVBADLMTD",$JOB))
End DoDot:1
QUIT
+6 ;Replace "##FFFF##" with Form Feeds - code needed for LINUX environments
+7 SET I=0
FOR
SET I=$ORDER(^TMP("DVBA",$JOB,1,I))
if 'I
QUIT
Begin DoDot:1
+8 if ^TMP("DVBA",$JOB,1,I)["##FFFF##"
SET ^TMP("DVBA",$JOB,1,I)=$PIECE(^TMP("DVBA",$JOB,1,I),"##FFFF##")_$CHAR(13,12)_$PIECE(^TMP("DVBA",$JOB,1,I),"##FFFF##",2)
+9 SET ^TMP("DVBA",$JOB,1,I)=^TMP("DVBA",$JOB,1,I)_$CHAR(13)
+10 if ^TMP("DVBA",$JOB,1,I)["$END"
SET ^TMP("DVBA",$JOB,1,I)=""
End DoDot:1
+11 SET MSG=$NAME(^TMP("DVBA",$JOB))
+12 IF ($GET(RPID)=5)&($GET(DVBADLMTR)=",")
SET MSG=$NAME(^TMP("INSUFF",$JOB))
+13 QUIT
CHECK ; VALIDATE INPUT PARAMETERS
+1 IF $GET(PARM)=""
SET DVBERR=1
SET ^TMP("DVBA",$JOB,1)="0^Undefined Input Parameters"
+2 QUIT
+3 ;
SDPP ; Report # 7 - Full (Patient Profile MAS) Report
+1 ;Parameters
+2 ;=============
+3 ; DFN : Patient Identification Number
+4 ; SDR : R/Range or A/All
+5 ; SDBD : Begining date
+6 ; SDED : Ending date
+7 ; SDP : Print the profile? 1 OR 0
+8 ; SDTYP(2) : Print appointments? 1 OR 0
+9 ; SDTYP(1) : Print add/edits? 1 or 0
+10 ; SDTYP(4) : Print enrollments? 1 or 0
+11 ; SDTYP(3) : Print dispositions? 1 OR 0
+12 ; SDTYP(7) : Print team information? 1 OR 0
+13 ; SDTYP(5) : Print means test? 1 OR 0
+14 ;
+15 NEW SDTYP,SDBD,SDED,SDACT,SDPRINT,SDYES,SDRANGE,SDBEG,SDEN
+16 SET ^XTMP("JAP",$JOB,$$NOW^XLFDT(),"SDPP")=PARM
+17 SET DFN=$PIECE(PARM,"^",1)
SET SDR=$PIECE(PARM,"^",2)
SET SDBD=$PIECE(PARM,"^",3)
SET SDED=$PIECE(PARM,"^",4)
+18 SET SDP=$PIECE(PARM,"^",5)
SET SDTYP(2)=$PIECE(PARM,"^",6)
SET SDTYP(1)=$PIECE(PARM,"^",7)
+19 SET SDTYP(4)=$PIECE(PARM,"^",8)
SET SDTYP(3)=$PIECE(PARM,"^",9)
SET SDTYP(7)=$PIECE(PARM,"^",10)
SET SDTYP(5)=$PIECE(PARM,"^",11)
+20 DO VAL
if DVBERR
QUIT
+21 SET SDACT=""
SET (SDYES,SDRANGE,SDPRINT)=0
+22 IF SDR="R"
SET SDRANGE=1
+23 IF SDP=1
SET SDYES=1
SET SDPRINT=1
+24 IF 'SDRANGE
SET (SDBD,SDBEG)=2800101
SET (SDED,SDEND)=$$ENDDT()
SET SDHDR=1
+25 DO ENS^%ZISS
+26 SET SDPRINT=1
+27 ;appointments
if (SDTYP(2)=1)
SET SDTYP(2)=""
+28 if (SDTYP(2)=0)
KILL SDTYP(2)
+29 ;add/edits
if (SDTYP(1)=1)
SET SDTYP(1)=""
+30 if (SDTYP(1)=0)
KILL SDTYP(1)
+31 ;enrollments
IF (SDTYP(4)=1)
SET SDTYP(4)=""
SET SDACT=0
+32 if (SDTYP(4)=0)
KILL SDTYP(4)
+33 ;dispositions
if (SDTYP(3)=1)
SET SDTYP(3)=""
+34 if (SDTYP(3)=0)
KILL SDTYP(3)
+35 ;means test
if (SDTYP(5)=1)
SET SDTYP(5)=""
+36 if (SDTYP(5)=0)
KILL SDTYP(5)
+37 ;team information
IF SDTYP(7)=1
Begin DoDot:1
+38 SET SDTYP(7)=""
SET GBL="^TMP(""SDPP"","_$JOB_")"
End DoDot:1
+39 if (SDTYP(7)=0)
KILL SDTYP(7)
+40 DO PRINT^SDPPRT
+41 SET VALMBCK="R"
+42 QUIT
ENDDT() ;Calculate end date for "all" date
+1 NEW DVBAPPTS,DVBX
+2 SET DVBAPPTS(1)=2800101
SET DVBAPPTS(4)=DFN
SET DVBAPPTS("SORT")="P"
+3 SET DVBAPPTS("FLDS")=1
SET DVBAPPTS("MAX")=-1
+4 SET DVBX=$SELECT(($$SDAPI^SDAMA301(.DVBAPPTS)>0):$ORDER(^TMP($JOB,"SDAMA301",DFN,0)),1:DT_.24)
+5 KILL ^TMP($JOB,"SDAMA301")
+6 QUIT DVBX
+7 ;
VIEW ; Report # 9 - View Registration Data Report
+1 ; Parameters
+2 ; ==========
+3 ; DFN : Patient Identification Number
+4 ;
+5 USE IO
+6 SET DFN=$PIECE(PARM,"^",1)
+7 DO VAL
if DVBERR
QUIT
+8 DO EN1^DGRP
+9 QUIT
+10 ;
DSRP ; Report # 6 - Reprint a Notice of Discharge Report
+1 ; Parameters
+2 ; % : 1=Report on all veterans for a given day (BDATE required)
+3 ; : 0=Report on a single Veteran (DFN required)
+4 ; BDATE : Original Processing Date - $H/FileMan
+5 ; DFN : Patient Identification Number
+6 ;
+7 NEW %,BDATE,DFN,DFNIEN
+8 SET %=$PIECE(PARM,"^",1)
SET BDATE=$PIECE(PARM,"^",2)
SET DFN=$PIECE(PARM,"^",3)
SET DFNIEN=""
+9 IF BDATE=""
SET DVBERR=1
SET ^TMP("DVBA",$JOB,1)="0^Incorrect Date"
QUIT
+10 DO DUZ2^DVBAUTIL
+11 USE IO
+12 DO VAL
if DVBERR
QUIT
+13 IF %=1
Begin DoDot:1
+14 SET HD="SINGLE NOTICE OF DISCHARGE REPRINTING"
+15 DO NOPARM^DVBAUTL2
+16 ;CAUTION: Short-circuit
IF $DATA(DVBAQUIT)
DO KILL^DVBAUTIL
QUIT
+17 SET DTAR=^DVB(396.1,1,0)
SET FDT(0)=$$FMTE^XLFDT(DT,"5DZ")
+18 SET HEAD="NOTICE OF DISCHARGE"
SET HEAD1="FOR "_$PIECE(DTAR,U,1)_" ON "_FDT(0)
+19 IF $DATA(^DVB(396.2,"B",DFN))
Begin DoDot:2
+20 SET DFNIEN=$ORDER(^DVB(396.2,"B",DFN,DFNIEN))
SET ADM=$PIECE(^DVB(396.2,DFNIEN,0),U,3)
+21 IF $DATA(^DGPM(+ADM,0))
IF $PIECE(^(0),U,17)]""
SET DCHPTR=$PIECE(^DGPM(+ADM,0),U,17)
SET DISCH=$SELECT($PIECE(^DGPM(DCHPTR,0),U,1)]"":$PIECE(^(0),U,1),1:"")
WRITE ?($X+5),"Discharge date: ",$$FMTE^XLFDT(DISCH,"5DZ")
+22 IF $PIECE(^DVB(396.2,DFNIEN,0),U,7)'=DVBAD2
WRITE *7,!!,"This does not belong to your RO.",!!
HANG 3
QUIT
+23 IF DFNIEN>0
SET XDA=DFNIEN
SET DA=$PIECE(^DVB(396.2,DFNIEN,0),U,1)
SET ADMDT=$PIECE(^DVB(396.2,DFNIEN,0),U,2)
SET MB=$PIECE(^(0),U,3)
+24 DO REPRINT^DVBADSNT
End DoDot:2
End DoDot:1
QUIT
+25 DO DEQUE^DVBADSRP
+26 QUIT
+27 ;
SPRPT ; Report # 8 - OP(Operation Report)
+1 ;Parameters
+2 ;=============
+3 ; DFN : Patient Identification Number
+4 ; DVBRTN : Select Operation
+5 ;
+6 ;CAPRI-11150;JCS;06/27/2024
+7 ; Report re-write due to interference with RPC Broker
+8 ;
+9 NEW DFN,DVBRTN,DVBSITE,DVBSINED,DVBSTAT,DVBDTITL,DVBTIU
+10 IF $ORDER(^SRO(133,1))'="B"
SET DVBSITE=1
+11 SET DFN=$PIECE(PARM,"^",1)
SET DVBRTN=$PIECE(PARM,"^",2)
+12 DO VAL
if DVBERR
QUIT
+13 SET DVBSINED=0
SET DVBSTAT=""
SET DVBTIU=$PIECE($GET(^SRF(DVBRTN,"TIU")),"^")
+14 IF $GET(DVBTIU)
SET DVBSTAT=$$STATUS^SROESUTL(DVBTIU)
if DVBSTAT=7
SET DVBSINED=1
+15 IF $GET(DVBSINED)
SET DVBTIU=$PIECE($GET(^SRF(DVBRTN,"TIU")),"^")
IF $GET(DVBTIU)
DO PRNT^SROESPR(DVBRTN,DVBTIU,"Operation Report")
QUIT
+16 IF 'DVBSINED
WRITE !!," * * The Operation Report for this case is not yet available. * *"
+17 KILL ^TMP("SROP",$JOB),SRPARM,DVBDIRY
+18 QUIT
+19 ;
CRPON ; Report # - 4 Reprint C&P Final Report
+1 ;Parameters
+2 ;=============
+3 ; RTYPE : Select Reprint Option (D)ate or (V)eteran
+4 ; RUNDATE : ORIGINAL PROCESSING date
+5 ; ANS : Reprinted by the RO or MAS
+6 ; % : LAB 1 OR 0
+7 ; DA(1) : Patient IEN for lab results
+8 ; DFN : Patient Identification Number
+9 ;
+10 USE IO
+11 NEW ONE,DVBAQ,DVBAWHO
+12 SET DVBAWHO=$PIECE($GET(PARM),U,8)
SET DVBAQ=""
+13 SET RTYPE=$PIECE(PARM,"^",1)
SET RUNDATE=$PIECE(PARM,"^",2)
SET ANS=$PIECE(PARM,"^",3)
SET %=$PIECE(PARM,"^",4)
SET DA(1)=$PIECE(PARM,"^",5)
SET DFN=$PIECE(PARM,"^",6)
SET DA=DA(1)
+14 IF RTYPE="V"
DO VAL
if DVBERR
QUIT
+15 SET XDD=^DD("DD")
SET $PIECE(ULINE,"_",70)="_"
SET ONE="N"
SET Y=DT
+16 XECUTE XDD
SET HD="Reprint C & P Exams"
SET SUPER=0
+17 IF $DATA(^XUSEC("DVBA C SUPERVISOR",DUZ))
SET SUPER=1
+18 SET DVBCDT(0)=Y
SET PGHD="Compensation and Pension Exam Report"
SET LOC=DUZ(2)
SET PG=0
SET DVBCSITE=$SELECT($DATA(^DVB(396.1,1,0)):$PIECE(^(0),U,1),1:"Not specified")
+19 IF "^D^V^"'[RTYPE
SET DVBERR=1
SET ^TMP("DVBA",$JOB,1)="0^Incorrect Data Type"
QUIT
+20 IF ANS="R"
KILL AUTO
+21 IF ANS="M"
SET AUTO=1
+22 IF "^M^R^"'[ANS
SET DVBERR=1
SET ^TMP("DVBA",$JOB,1)="0^Incorrect Data Type"
QUIT
+23 IF RTYPE="D"
DO GO^DVBCRPRT
QUIT
+24 ;DVBA*196 - I6184115FY16 FIX VALIDATION LOGIC FOR "BY VETERAN" TO MEET REQUIREMENTS IN PATCH 192
+25 IF RTYPE="V"
Begin DoDot:1
+26 ;AJF;Request Status conversion
+27 SET RQST=$$RSTAT^DVBCUTL8($PIECE(^DVB(396.3,DA,0),U,18))
+28 SET ONE="Y"
SET RO=$PIECE(^DVB(396.3,DA,0),U,3)
+29 IF DVBAWHO=0
Begin DoDot:2
+30 IF RO'=DUZ(2)&('$DATA(AUTO))&(SUPER=0)
WRITE !!,*7,"Those results do not belong to your office.",!!
SET DVBAQ=1
QUIT
+31 ;AJF;Request Status conversion
+32 IF RO=DUZ(2)&('$DATA(AUTO))&("RC"'[RQST)
WRITE *7,!!,"This request has not been released to the Regional Office yet.",!!
SET DVBAQ=1
QUIT
+33 SET PRTDATE=$PIECE(^DVB(396.3,DA,0),U,16)
IF PRTDATE=""
WRITE *7,!!,"This has never been printed.",!!
IF SUPER=0
SET OUT=1
SET DVBAQ=1
QUIT
End DoDot:2
+34 IF DVBAWHO=1
Begin DoDot:2
+35 ;AJF;Request Status conversion
+36 IF "RC"'[RQST
WRITE *7,!!,"This request has not been released to the Regional Office yet.",!!
SET DVBAQ=1
QUIT
End DoDot:2
+37 IF DVBAQ=1
QUIT
+38 IF %=1
DO REN2^DVBCLABR
QUIT
+39 ;D OV^DVBCRPON
+40 KILL DVBAON2
DO SETLAB^DVBCPRNT
DO VARS^DVBCUTIL
Begin DoDot:2
+41 IF DVBAWHO=1
DO VBASTEP2^DVBCRPRT
+42 IF DVBAWHO=0
DO STEP2^DVBCRPRT
End DoDot:2
End DoDot:1
+43 QUIT
+44 ;
VBACRPON ; Report # - 4 Reprint C&P Final Report by VBA personnel
+1 ;Parameters
+2 ;=============
+3 ; RTYPE : Select Reprint Option (D)ate or (V)eteran
+4 ; RUNDATE : ORIGINAL PROCESSING date
+5 ; ANS : Reprinted by the RO or MAS
+6 ; % : LAB 1 OR 0
+7 ; DA(1) : Patient IEN for lab results
+8 ; DFN : Patient Identification Number
+9 ;
+10 SET DVBERR=0
+11 IF $DATA(^TMP("DVBA",$JOB))
SET DVBAX=(^TMP("DVBA",$JOB))
+12 USE IO
+13 NEW ONE
+14 SET RTYPE=$PIECE(PARM,"^",1)
SET RUNDATE=$PIECE(PARM,"^",2)
SET ANS=$PIECE(PARM,"^",3)
SET %=$PIECE(PARM,"^",4)
SET DA(1)=$PIECE(PARM,"^",5)
SET DFN=$PIECE(PARM,"^",6)
SET DA=DA(1)
+15 IF RTYPE="V"
DO VAL
if DVBERR
QUIT
+16 SET XDD=^DD("DD")
SET $PIECE(ULINE,"_",70)="_"
SET ONE="N"
SET Y=DT
+17 XECUTE XDD
SET HD="Reprint C & P Exams"
+18 SET DVBCDT(0)=Y
SET PGHD="Compensation and Pension Exam Report"
SET LOC=DUZ(2)
SET PG=0
SET DVBCSITE=$SELECT($DATA(^DVB(396.1,1,0)):$PIECE(^(0),U,1),1:"Not specified")
+19 IF "^D^V^"'[RTYPE
SET DVBERR=1
SET ^TMP("DVBA",$JOB,1)="0^Incorrect Data Type"
QUIT
+20 IF ANS="R"
KILL AUTO
+21 IF ANS="M"
SET AUTO=1
+22 IF "^M^R^"'[ANS
SET DVBERR=1
SET ^TMP("DVBA",$JOB,1)="0^Incorrect Data Type"
QUIT
+23 IF RTYPE="D"
DO VBAGO^DVBCRPRT
QUIT
+24 IF RTYPE="V"
Begin DoDot:1
+25 SET ONE="Y"
SET RO=$PIECE(^DVB(396.3,DA,0),U,3)
+26 SET PRTDATE=$PIECE(^DVB(396.3,DA,0),U,16)
+27 IF %=1
DO REN2^DVBCLABR
QUIT
+28 KILL DVBAON2
DO SETLAB^DVBCPRNT
DO VARS^DVBCUTIL
DO VBASTEP2^DVBCRPRT
End DoDot:1
+29 QUIT
+30 ;
CIRPT ; Report # 5 - Insufficient Exam Report
+1 ;Parameters
+2 ;=============
+3 ; RPTTYPE : D/Detailed or S/Summary
+4 ; BEGDT : Beginning date $H/FileMan
+5 ; ENDDT : Ending date $H/FileMan
+6 ; RESANS : Insufficient Reason
+7 ; DVBAPRTY : Priority of Exam Code
+8 ; AO : Agent Orange
+9 ; BDD : Benefits Delivery at Discharge / Quick Start
+10 ; IDES : Integrated Disability Evaluation System
+11 ; ALL : All Others (Original Report w/ all codes except the above)
+12 ; DVBADLMTR: 0=non-delimited format, ","=delimiter for .csv file for EXCEL
+13 ;
+14 NEW DVBAPRTY,RPTTYPE,BEGDT,ENDDT,RESANS
+15 USE IO
+16 SET RPTTYPE=$PIECE(PARM,"^",1)
SET BEGDT=$PIECE(PARM,"^",2)
SET ENDDT=$PIECE(PARM,"^",3)
SET RESANS=""
+17 SET DVBADLMTR=$PIECE(PARM,"^",6)
SET DVBADLMTR=$SELECT(DVBADLMTR=1:",",1:0)
+18 SET ENDDT=ENDDT_".2359"
+19 IF RPTTYPE="S"
DO SUM^DVBCIRP2
QUIT
+20 IF RPTTYPE="D"
Begin DoDot:1
+21 DO INREAS
+22 ;invalid reason sent
if ($DATA(^TMP("DVBA",$JOB,1)))
QUIT
+23 DO EXMTPE
DO DETAIL^DVBCIRP2
End DoDot:1
+24 QUIT
+25 ;
EXMTPE ;exam types (retrieve all for filter)
+1 NEW DVBAXIFN
+2 FOR DVBAXIFN=0:0
SET DVBAXIFN=$ORDER(^DVB(396.6,DVBAXIFN))
if +DVBAXIFN=0
QUIT
Begin DoDot:1
+3 SET ^TMP($JOB,"XMTYPE",DVBAXIFN)=""
End DoDot:1
+4 QUIT
INREAS ;insufficient reason (validate specific or retrieve all)
+1 NEW DVBAXIFN
+2 ;use all insufficient reasons
if (RESANS="")
Begin DoDot:1
+3 FOR DVBAXIFN=0:0
SET DVBAXIFN=$ORDER(^DVB(396.94,DVBAXIFN))
if +DVBAXIFN=0
QUIT
Begin DoDot:2
+4 SET DVBAARY("REASON",DVBAXIFN)=""
End DoDot:2
End DoDot:1
+5 ;D:(RESANS'="") ;use specific insufficient reason
+6 ;.I ('$D(^DVB(396.94,+RESANS))) D ;validate IEN
+7 ;..S DVBERR=1,^TMP("DVBA",$J,1)="0^Invalid Insufficient Reason IEN"
+8 ;.E S DVBAARY("REASON",+RESANS)=""
+9 QUIT
+10 ;
CRMS ; Report # 1 - Regional Office 21- day Certificate Printing Report.
+1 ; No Parameters
+2 ;
+3 USE IO
+4 DO ^DVBACRMS
+5 QUIT
+6 ;
CRRR ; Report # 2 - Reprint a 21 - day Certificate for the RO
+1 ;Parameters
+2 ;=============
+3 ; DVBSEL : Select one of the following:
+4 ; N Patient Name
+5 ; D ORIGINAL PROCESSING DATE
+6 ; SDATE : ORIGINAL PROCESSING date - $H/FileMan
+7 ; XDA : Patient IEN
+8 ;
+9 USE IO
+10 SET DVBSEL=$PIECE(PARM,"^",1)
SET SDATE=$PIECE(PARM,"^",2)
SET XDA=$PIECE(PARM,"^",3)
+11 IF "^D^N^"'[DVBSEL
SET DVBERR=1
SET ^TMP("DVBA",$JOB,1)="0^Incorrect Data Type"
QUIT
+12 IF DVBSEL="D"
Begin DoDot:1
+13 IF SDATE=""
SET DVBERR=1
SET ^TMP("DVBA",$JOB,1)="0^Undefined Date"
QUIT
+14 SET %DT="X"
SET X=SDATE
DO ^%DT
IF Y<0
Begin DoDot:2
+15 SET DVBERR=1
SET ^TMP("DVBA",$JOB,1)="0^Incorrect Date Format"
End DoDot:2
QUIT
End DoDot:1
IF DVBERR
QUIT
+16 IF DVBSEL="N"
Begin DoDot:1
+17 IF XDA=""
SET DVBERR=1
SET ^TMP("DVBA",$JOB,1)="0^Undefined Patient IEN"
QUIT
+18 SET DIC=2
SET DIC(0)="NZX"
SET X=XDA
DO ^DIC
IF Y<0
Begin DoDot:2
+19 SET DVBERR=1
SET ^TMP("DVBA",$JOB,1)="0^Invalid Patient Name."
End DoDot:2
IF DVBERR
QUIT
+20 SET DFN=XDA
End DoDot:1
IF DVBERR
QUIT
+21 DO INIT^DVBACRRR
IF 'CONT
QUIT
+22 DO HDR^DVBACRRR
DO DATA^DVBACRRR
+23 QUIT
+24 ;
CPRNT ; Report # 3 - Print C&P Final Report (manual) Report
+1 ; No Parameters
+2 ;
+3 SET XDD=^DD("DD")
SET $PIECE(ULINE,"_",70)="_"
SET Y=DT
+4 XECUTE XDD
SET DVBCDT(0)=Y
SET PGHD="Compensation and Pension Exam Report"
SET DVBCSITE=$SELECT($DATA(^DVB(396.1,1,0)):$PIECE(^(0),U,1),1:"Not Specified")
+5 DO GO^DVBCPRNT
+6 QUIT
VAL ; VALIDATE PATIENT
+1 IF $GET(DFN)=""
SET DVBERR=1
SET ^TMP("DVBA",$JOB,1)="0^Undefined Patient IEN"
GOTO END
+2 SET DIC=2
SET DIC(0)="NZX"
SET X=DFN
DO ^DIC
+3 IF Y<0
SET DVBERR=1
SET ^TMP("DVBA",$JOB,1)="0^Invalid Patient Name."
GOTO END
+4 QUIT
+5 ;
VALDATE(DVBADTE) ;Validate Date
+1 ;dates must be valid internal FileMan format
+2 NEW X,Y,%DT
+3 SET %DT="X"
SET X=DVBADTE
DO ^%DT
+4 if (Y=-1)
SET DVBERR=1
SET ^TMP("DVBA",$JOB,1)="0^Invalid FileMan formatted date."
+5 QUIT
+6 ;
CNHDEOC ; Report #10 - FBCNH Display Episode of Care
+1 ; Parameters
+2 ; ==========
+3 ; DFN : IEN in PATIENT (#2) file
+4 ; IFN : IEN in FEE CNH ACTIVITY (#162.3) file
+5 ;
+6 USE IO
+7 NEW DFN,IFN
+8 SET DFN=$PIECE(PARM,U,1)
SET IFN=$PIECE(PARM,U,2)
+9 ;DBIA#: 5566
DO ^FBNHDEC
+10 QUIT
+11 ;
CNHRP ; Report #11 - FBCNH Roster Print
+1 ; Parameters
+2 ; ==========
+3 ; DVBADLMTD : 0 (Standard) or 1 (Delimited)
+4 ;
+5 USE IO
+6 SET DVBADLMTD=+$PIECE($GET(PARM),U)
+7 ;DBIA#: 5566
DO START^FBNHROS
+8 QUIT
+9 ;
CNHRAD ; Report #12 - FBCNH Report of Admissions/Discharges
+1 ; Parameters
+2 ; ==========
+3 ; BEGDATE : Start date in FM format
+4 ; ENDDATE : End date in FM format
+5 ; DVBADLMTD : 0 (Standard) or 1 (Delimited)
+6 ;
+7 USE IO
+8 NEW BEGDATE,ENDDATE
+9 SET BEGDATE=$PIECE(PARM,U,1)
SET ENDDATE=$PIECE(PARM,U,2)
+10 SET DVBADLMTD=+$PIECE(PARM,U,3)
+11 DO VALDATE(BEGDATE)
DO VALDATE(ENDDATE)
+12 ;DBIA#: 5566
if ('+DVBERR)
DO START^FBNHAMIE
+13 QUIT
+14 ;
CNHSE90D ; Report #13 - FBCNH Stays in Excess of 90 Days
+1 ; Parameters
+2 ; ==========
+3 ; FBDT : Effective date in FM format
+4 ; DVBADLMTD : 0 (Standard) or 1 (Delimited)
+5 ;
+6 USE IO
+7 NEW FBDT
+8 SET FBDT=$PIECE(PARM,U,1)
SET DVBADLMTD=+$PIECE(PARM,U,2)
+9 DO VALDATE(FBDT)
+10 ;DBIA#: 5566
if ('+DVBERR)
DO START^FBNHAMI2
+11 QUIT
+12 ;
HFS() ; -- get hfs file name
+1 NEW H
+2 SET H=$HOROLOG
+3 QUIT "DVBA_"_$JOB_"_"_$PIECE(H,",")_"_"_$PIECE(H,",",2)_".DAT"
+4 ;
HFSOPEN(HANDLE,DVBHFS,DVBMODE) ; Open File
+1 SET DVBDIRY=$$GET^XPAR("DIV","DVB HFS SCRATCH")
+2 ;I DVBDIRY="" S ECERR=1 D Q
+3 ;. S ^TMP("DVBA",$J,1)="0^A scratch directory for reports doesn't exist"
+4 DO OPEN^%ZISH(HANDLE,,DVBHFS,$GET(DVBMODE,"W"))
if POP
Begin DoDot:1
+5 SET DVBERR=1
SET ^TMP("DVBA",$JOB,1)="0^Unable to open file "
End DoDot:1
if POP
QUIT
+6 ;resets screen position and adds page break flag - added to deal with Linux environments.
SET IOF="$$IOF^DVBAB82"
+7 QUIT
+8 ;
HFSCLOSE(HANDLE,DVBHFS) ;Close HFS and unload data
+1 NEW DVBDEL,X,%ZIS
+2 DO CLOSE^%ZISH(HANDLE)
+3 SET DVBDEL(DVBHFS)=""
+4 SET ROOT=$NAME(^TMP("DVBA",$JOB,1))
+5 if ('+DVBERR)
KILL @ROOT
+6 SET X=$$FTG^%ZISH(,DVBHFS,$NAME(@ROOT@(1)),4)
+7 SET X=$$DEL^%ZISH(,$NAME(DVBDEL))
+8 QUIT
+9 ;
IOF() ;used to reset position and insert page break flag when @IOF is executed.
+1 SET $X=0
SET $Y=0
+2 QUIT "##FFFF##"_$CHAR(13,10)
+3 ;
REQSTAT ; Report #14 - Request Status by Date Range
+1 ; Parameters
+2 ; ==========
+3 ; BEGDAT : Start date in FM format
+4 ; ENDDAT : End date in FM format
+5 ; REQSTAT : Request Status filter
+6 ; ISDELIM : 0 (Standard format); 1 (Delimited format)
+7 ; ISNODT : 0 (Use date range); 1 (Ignore date range)
+8 USE IO
+9 NEW BEGDAT,ENDDAT,REQSTAT
+10 SET BEGDAT=$PIECE(PARM,U,1)
SET ENDDAT=$PIECE(PARM,U,2)
+11 SET REQSTAT=$PIECE(PARM,U,3)
SET ISDELIM=$PIECE(PARM,U,4)
SET ISNODT=$PIECE(PARM,U,5)
+12 DO VALDATE(BEGDAT)
DO VALDATE(ENDDAT)
+13 if ('+DVBERR)
DO REQSTAT^DVBARSBD(BEGDAT,ENDDAT,REQSTAT,ISDELIM,ISNODT)
+14 QUIT
+15 ;
DVBA8861 ; Report #15 - Form 28-8861 Status Report
+1 ; Parameters
+2 ; ==========
+3 ; BEGDAT - Start date in FM format
+4 ; ENDDAT - End date in FM format
+5 ; ROSTAT - Regional Office filter
+6 ; REQSTAT - Request Status filter
+7 ; DELIMTER - 0 (Standard format); 1 (Delimited format)
+8 ;
+9 USE IO
+10 NEW BEGDAT,ENDDAT,REQSTAT
+11 SET BEGDAT=$PIECE(PARM,U,1)
SET ENDDAT=$PIECE(PARM,U,2)
+12 SET ROSTAT=$PIECE(PARM,U,3)
SET REQSTAT=$PIECE(PARM,U,4)
SET DELIMTER=$PIECE(PARM,U,5)
+13 DO VALDATE(BEGDAT)
DO VALDATE(ENDDAT)
+14 if ('+DVBERR)
DO STATRPT^DVBA8861(BEGDAT,ENDDAT,ROSTAT,REQSTAT,DELIMTER)
+15 QUIT
