- 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 Mar 13, 2025@20:53:55 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
