DVBCUTL3 ;ALB/GTS-557/THM-DVBCUTL2, CONTINUED ; 5/17/91 11:35 AM
;;2.7;AMIE;**132,193**;Apr 10, 1995;Build 84
;
KILL I $D(LKILL) K LKILL D LKILL
K C0,DVBCLTR,DVBCNOW,DVBCSORT,LI,LREXMDT,LV,PGRN,ROUT,RT,TSTAT,XMB,XT,EXNAME,OTHDIS1,OTHDIS2,PG,REQRO,RSTAT,TIME,ZI,ZZI,DAYEX,DINUM,DTCAN,ERDAYS,EXMDA,FB,OLDAYS,^TMP("DVBC",$J),^TMP("DVBCLAB",$J),DVBCBDT,DVBCLOC,DVBCN,DVBCRLOC
K HD4,RONUM,TPRT,DG,LRPARAM,RARPT,SUPER,^TMP($J),^TMP("DVBC","BULL",$J),EXCNT,RTYPE,XD,XLINE,ZC,LY,LZ,MX,MY,WKSNUM,HD7,HD8,HD9,LN1,LN2,DXCMT,CANBY,CANDT,CANREM,CFLOC,CFREQ,CMBN,DVBCI,ELIGCOD,ELIGSDT,ELIGST,DVBCD2
K EXM,EXMDT,EXMPL,EXPHYS,FREAS,HD5,HD6,HD7,HD8,HD9,LNH,NREQDA,OLREQDA,OTHDOC,OWNER,PDSRV,PFAX,POWSTAT,SITE,SITE1,SRVCON,SRVEDT,SRVPCT,SRVSDT,SUB,TIME,TOT,USER,USERNM,USR,VETST,WRKSHT,XFERDT,XFERSITE,XMER,XMREC,XMRG,ZJ,ZK
K HD91,CNUM,DFN,DX,DXCOD,DXNUM,I,LINE,DVBCRALC,PCT,SC,SSN,CANCBY,CANCDT,CANCREM,DATRETN,EXST,FA,OWNDOM,REMK,TSTA1,XMFG,YY,ZG,ZH,DVBCAO,XCN,MANUAL
K DVBCTYPE,HD7,HD8,HD9,HD91,RDATE1,TPRT,XJ,RONAM,PNAM,^TMP($J)
K ZTQUEUED,ZIP4,ZIP,Z1,ZH,XRTN,XMVAR,XMRG,XMREC,XMER,XMCNT,XD,WRKSHT,VETST
K USER,USERNM
Q
;
LKILL K LRO,LR0,LRAA,LRAAO,LRCDT,LRCMNT,LRNIDT,LRCW,LRDATA,LRDFN,LRDN,LRDOC,LRDPF,LREDT,LREND,LRFFLG,LRFOOT,LRHF,LRHI,LRIDT,LRLAB,LRLO,LRMNIDT,LROC,LRONESPC,LRONETST,LRORN,LRPC,LRPO,LRSDT,LRSPEC,LRSS,LRSTOP,LRSUB,LRTC,LRCNIDT
K LRTHER,LRTSTS,LRWRD,RACNI,RAST,RPTR,OK,LRBLOOD,LRPARAM,LRPLASMA,LRSERUM,LRUNKNOW,LRURINE,LRPANEL,LRTM60,LRDT0,LRLABKY
Q
; **The following routines are called by DVBCREQ1 **
DDIS1 S DXNUM=$P(^DPT(DFN,.372,DVBCXJI,0),U,1),PCT=$P(^(0),U,2)
S DVBCSC=$P(^(0),U,3)
S DVBCDX=$S($D(^DIC(31,DXNUM)):$P(^(DXNUM,0),U,1),1:"Unknown")
S DXCOD=$S($D(^DIC(31,DXNUM)):$P(^(DXNUM,0),U,3),1:"Unknown")
W ?2,DVBCDX,?37,$J(PCT,3,0)," %",?50,$S(DVBCSC=1:"Yes",1:"No")
W ?58,DXCOD,!
I IOST?1"C-".E W !,"VA Form 21-2507" D TERM
Q
;
DDIS ;display rated disabilities
I '$D(^DPT(DFN,.372)) W !?25,"No rated disabilities on file",!! Q
W !?2,"Rated Disability",?37,"Percent",?50,"SC ?",?58,"Dx Code",! W ?2 F LINE=1:1:63 W "-"
W !!
F DVBCXJI=0:0 S DVBCXJI=$O(^DPT(DFN,.372,DVBCXJI)) Q:DVBCXJI="" D DDIS1 Q:($D(GETOUT))
W !!
Q
;
TST W ?3
F DA=0:0 S DA=$O(^DVB(396.4,"C",DA(1),DA)) Q:(DA="")!($D(GETOUT)) D CONTST
Q
;
CONTST K PRINT S TSTAT=$P(^DVB(396.4,DA,0),U,4)
S TST=$P(^DVB(396.4,DA,0),U,3)
S PRTNM=$S($D(^DVB(396.6,TST,0)):$P(^(0),U,2),1:"")
D TST1
Q
;
TST1 I $Y>(IOSL-3) W !,"VA Form 21-2507" I IOST?1"C-".E D TERM Q:($D(GETOUT))
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) ;tsta1=cancellation reason
;DVBA*132 - added Exam Ref# to end of Write command below
W:(($L(PRTNM)+$L(TSTA1)+$X)>55!($D(DVBAINSF))) !?1 W $S(PRTNM]"":PRTNM,1:"Missing exam name")_$S(TSTA1]"":" - cancelled ("_TSTA1_")",TSTAT="T":" - Transferred",TSTAT="":" (Unknown status)",1:"")," (Exam Ref#: ",DA,")"
I TSTAT="T" S X=$S($D(^DIC(4.2,+X,0)):$P(^(0),U,1),1:"unknown site") W " to ",$P(X,".",1)
W "; "
I $D(DVBAINSF) DO
.I +$P(^DVB(396.4,DA,0),U,11)>0 DO
..I $Y>(IOSL-7) D BOT D:'$D(GETOUT) HDR^DVBCREQ1
..I '$D(GETOUT) DO
...S TVAR(1,0)="0,3,0,2,0^Insufficient Reason: "_$P(^DVB(396.94,$P(^DVB(396.4,DA,0),U,11),0),U,1)
...S TVAR(2,0)="0,3,0,2:1,0^Insufficient Remarks: "
...D WR^DVBAUTL4("TVAR")
...K TVAR
...I $D(^DVB(396.4,DA,"INREM")) DO
....K ^UTILITY($J,"W")
....S DIWL=5,DIWF="NW"
....F LPCNT=0:0 S LPCNT=$O(^DVB(396.4,DA,"INREM",LPCNT)) Q:LPCNT=""!($D(GETOUT)) DO ;**Loop Insufficient Remarks
.....S X=^DVB(396.4,DA,"INREM",LPCNT,0)
.....S:X="<" X=" <"
.....S X=$P(X,"<",1)
.....D ^DIWP ;**Print Insufficient Remarks
.....I $Y>(IOSL-8),$O(^DVB(396.4,DA,"INREM",LPCNT))]"" DO
......D BOT D:'$D(GETOUT) HDR^DVBCREQ1,RMRK
....D:'$D(GETOUT)&($O(^DVB(396.4,DA,"INREM",0))>0) ^DIWW
...W !!
Q
;
TERM ; ** If output to CRT, display 'Continue' prompt **
S DIR(0)="F,O^^",DIR("A")="Enter [Return] to continue or ""^"" to exit"
K GETOUT D ^DIR S:$D(DTOUT)!($D(DUOUT)) GETOUT=1
I '$D(GETOUT) W @IOF K DIR,DIRUT
Q
;
BOT ;**Write form # at bottom
I IOST?1"C-".E F LPCNT1=$Y:1:(IOSL-6) W !
I IOST'?1"C-".E F LPCNT1=$Y:1:(IOSL-4) W !
W !,"VA Form 21-2507"
I IOST?1"C-".E D TERM
Q
;
RMRK ;** Write remarks continued at top of page
W !!?3,"Insufficient remarks, continued",!!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBCUTL3 4472 printed Nov 22, 2024@16:59:24 Page 2
DVBCUTL3 ;ALB/GTS-557/THM-DVBCUTL2, CONTINUED ; 5/17/91 11:35 AM
+1 ;;2.7;AMIE;**132,193**;Apr 10, 1995;Build 84
+2 ;
KILL IF $DATA(LKILL)
KILL LKILL
DO LKILL
+1 KILL C0,DVBCLTR,DVBCNOW,DVBCSORT,LI,LREXMDT,LV,PGRN,ROUT,RT,TSTAT,XMB,XT,EXNAME,OTHDIS1,OTHDIS2,PG,REQRO,RSTAT,TIME,ZI,ZZI,DAYEX,DINUM,DTCAN,ERDAYS,EXMDA,FB,OLDAYS,^TMP("DVBC",$JOB),^TMP("DVBCLAB",$JOB),DVBCBDT,DVBCLOC,DVBCN,DVBCRLOC
+2 KILL HD4,RONUM,TPRT,DG,LRPARAM,RARPT,SUPER,^TMP($JOB),^TMP("DVBC","BULL",$JOB),EXCNT,RTYPE,XD,XLINE,ZC,LY,LZ,MX,MY,WKSNUM,HD7,HD8,HD9,LN1,LN2,DXCMT,CANBY,CANDT,CANREM,CFLOC,CFREQ,CMBN,DVBCI,ELIGCOD,ELIGSDT,ELIGST,DVBCD2
+3 KILL EXM,EXMDT,EXMPL,EXPHYS,FREAS,HD5,HD6,HD7,HD8,HD9,LNH,NREQDA,OLREQDA,OTHDOC,OWNER,PDSRV,PFAX,POWSTAT,SITE,SITE1,SRVCON,SRVEDT,SRVPCT,SRVSDT,SUB,TIME,TOT,USER,USERNM,USR,VETST,WRKSHT,XFERDT,XFERSITE,XMER,XMREC,XMRG,ZJ,ZK
+4 KILL HD91,CNUM,DFN,DX,DXCOD,DXNUM,I,LINE,DVBCRALC,PCT,SC,SSN,CANCBY,CANCDT,CANCREM,DATRETN,EXST,FA,OWNDOM,REMK,TSTA1,XMFG,YY,ZG,ZH,DVBCAO,XCN,MANUAL
+5 KILL DVBCTYPE,HD7,HD8,HD9,HD91,RDATE1,TPRT,XJ,RONAM,PNAM,^TMP($JOB)
+6 KILL ZTQUEUED,ZIP4,ZIP,Z1,ZH,XRTN,XMVAR,XMRG,XMREC,XMER,XMCNT,XD,WRKSHT,VETST
+7 KILL USER,USERNM
+8 QUIT
+9 ;
LKILL KILL LRO,LR0,LRAA,LRAAO,LRCDT,LRCMNT,LRNIDT,LRCW,LRDATA,LRDFN,LRDN,LRDOC,LRDPF,LREDT,LREND,LRFFLG,LRFOOT,LRHF,LRHI,LRIDT,LRLAB,LRLO,LRMNIDT,LROC,LRONESPC,LRONETST,LRORN,LRPC,LRPO,LRSDT,LRSPEC,LRSS,LRSTOP,LRSUB,LRTC,LRCNIDT
+1 KILL LRTHER,LRTSTS,LRWRD,RACNI,RAST,RPTR,OK,LRBLOOD,LRPARAM,LRPLASMA,LRSERUM,LRUNKNOW,LRURINE,LRPANEL,LRTM60,LRDT0,LRLABKY
+2 QUIT
+3 ; **The following routines are called by DVBCREQ1 **
DDIS1 SET DXNUM=$PIECE(^DPT(DFN,.372,DVBCXJI,0),U,1)
SET PCT=$PIECE(^(0),U,2)
+1 SET DVBCSC=$PIECE(^(0),U,3)
+2 SET DVBCDX=$SELECT($DATA(^DIC(31,DXNUM)):$PIECE(^(DXNUM,0),U,1),1:"Unknown")
+3 SET DXCOD=$SELECT($DATA(^DIC(31,DXNUM)):$PIECE(^(DXNUM,0),U,3),1:"Unknown")
+4 WRITE ?2,DVBCDX,?37,$JUSTIFY(PCT,3,0)," %",?50,$SELECT(DVBCSC=1:"Yes",1:"No")
+5 WRITE ?58,DXCOD,!
+6 IF IOST?1"C-".E
WRITE !,"VA Form 21-2507"
DO TERM
+7 QUIT
+8 ;
DDIS ;display rated disabilities
+1 IF '$DATA(^DPT(DFN,.372))
WRITE !?25,"No rated disabilities on file",!!
QUIT
+2 WRITE !?2,"Rated Disability",?37,"Percent",?50,"SC ?",?58,"Dx Code",!
WRITE ?2
FOR LINE=1:1:63
WRITE "-"
+3 WRITE !!
+4 FOR DVBCXJI=0:0
SET DVBCXJI=$ORDER(^DPT(DFN,.372,DVBCXJI))
if DVBCXJI=""
QUIT
DO DDIS1
if ($DATA(GETOUT))
QUIT
+5 WRITE !!
+6 QUIT
+7 ;
TST WRITE ?3
+1 FOR DA=0:0
SET DA=$ORDER(^DVB(396.4,"C",DA(1),DA))
if (DA="")!($DATA(GETOUT))
QUIT
DO CONTST
+2 QUIT
+3 ;
CONTST KILL PRINT
SET TSTAT=$PIECE(^DVB(396.4,DA,0),U,4)
+1 SET TST=$PIECE(^DVB(396.4,DA,0),U,3)
+2 SET PRTNM=$SELECT($DATA(^DVB(396.6,TST,0)):$PIECE(^(0),U,2),1:"")
+3 DO TST1
+4 QUIT
+5 ;
TST1 IF $Y>(IOSL-3)
WRITE !,"VA Form 21-2507"
IF IOST?1"C-".E
DO TERM
if ($DATA(GETOUT))
QUIT
+1 SET TSTA1=""
+2 IF $DATA(^DVB(396.4,DA,"CAN"))
SET TSTA1=$PIECE(^DVB(396.4,DA,"CAN"),U,3)
+3 IF $DATA(^DVB(396.4,DA,"TRAN"))
SET X=$PIECE(^DVB(396.4,DA,"TRAN"),U,3)
+4 ;tsta1=cancellation reason
if TSTA1]""
SET TSTA1=$PIECE(^DVB(396.5,TSTA1,0),U,1)
+5 ;DVBA*132 - added Exam Ref# to end of Write command below
+6 if (($LENGTH(PRTNM)+$LENGTH(TSTA1)+$X)>55!($DATA(DVBAINSF)))
WRITE !?1
WRITE $SELECT(PRTNM]"":PRTNM,1:"Missing exam name")_$SELECT(TSTA1]"":" - cancelled ("_TSTA1_")",TSTAT="T":" - Transferred",TSTAT="":" (Unknown status)",1:"")," (Exam Ref#: ",DA,")"
+7 IF TSTAT="T"
SET X=$SELECT($DATA(^DIC(4.2,+X,0)):$PIECE(^(0),U,1),1:"unknown site")
WRITE " to ",$PIECE(X,".",1)
+8 WRITE "; "
+9 IF $DATA(DVBAINSF)
Begin DoDot:1
+10 IF +$PIECE(^DVB(396.4,DA,0),U,11)>0
Begin DoDot:2
+11 IF $Y>(IOSL-7)
DO BOT
if '$DATA(GETOUT)
DO HDR^DVBCREQ1
+12 IF '$DATA(GETOUT)
Begin DoDot:3
+13 SET TVAR(1,0)="0,3,0,2,0^Insufficient Reason: "_$PIECE(^DVB(396.94,$PIECE(^DVB(396.4,DA,0),U,11),0),U,1)
+14 SET TVAR(2,0)="0,3,0,2:1,0^Insufficient Remarks: "
+15 DO WR^DVBAUTL4("TVAR")
+16 KILL TVAR
+17 IF $DATA(^DVB(396.4,DA,"INREM"))
Begin DoDot:4
+18 KILL ^UTILITY($JOB,"W")
+19 SET DIWL=5
SET DIWF="NW"
+20 ;**Loop Insufficient Remarks
FOR LPCNT=0:0
SET LPCNT=$ORDER(^DVB(396.4,DA,"INREM",LPCNT))
if LPCNT=""!($DATA(GETOUT))
QUIT
Begin DoDot:5
+21 SET X=^DVB(396.4,DA,"INREM",LPCNT,0)
+22 if X="<"
SET X=" <"
+23 SET X=$PIECE(X,"<",1)
+24 ;**Print Insufficient Remarks
DO ^DIWP
+25 IF $Y>(IOSL-8)
IF $ORDER(^DVB(396.4,DA,"INREM",LPCNT))]""
Begin DoDot:6
+26 DO BOT
if '$DATA(GETOUT)
DO HDR^DVBCREQ1
DO RMRK
End DoDot:6
End DoDot:5
+27 if '$DATA(GETOUT)&($ORDER(^DVB(396.4,DA,"INREM",0))>0)
DO ^DIWW
End DoDot:4
+28 WRITE !!
End DoDot:3
End DoDot:2
End DoDot:1
+29 QUIT
+30 ;
TERM ; ** If output to CRT, display 'Continue' prompt **
+1 SET DIR(0)="F,O^^"
SET DIR("A")="Enter [Return] to continue or ""^"" to exit"
+2 KILL GETOUT
DO ^DIR
if $DATA(DTOUT)!($DATA(DUOUT))
SET GETOUT=1
+3 IF '$DATA(GETOUT)
WRITE @IOF
KILL DIR,DIRUT
+4 QUIT
+5 ;
BOT ;**Write form # at bottom
+1 IF IOST?1"C-".E
FOR LPCNT1=$Y:1:(IOSL-6)
WRITE !
+2 IF IOST'?1"C-".E
FOR LPCNT1=$Y:1:(IOSL-4)
WRITE !
+3 WRITE !,"VA Form 21-2507"
+4 IF IOST?1"C-".E
DO TERM
+5 QUIT
+6 ;
RMRK ;** Write remarks continued at top of page
+1 WRITE !!?3,"Insufficient remarks, continued",!!
+2 QUIT
