source: FOIAVistA/tag/r/AUTOMATED_MED_INFO_EXCHANGE-DVBA-DVBC/DVBCUTL3.m@ 628

Last change on this file since 628 was 628, checked in by George Lilly, 14 years ago

initial load of FOIAVistA 6/30/08 version
File size: 4.1 KB
Line 
1DVBCUTL3 ;ALB/GTS-557/THM-DVBCUTL2, CONTINUED ; 5/17/91 11:35 AM
2 ;;2.7;AMIE;;Apr 10, 1995
3 ;
4KILL I $D(LKILL) K LKILL D LKILL
5 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
6 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
7 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
8 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
9 K DVBCTYPE,HD7,HD8,HD9,HD91,RDATE1,TPRT,XJ,RONAM,PNAM,^TMP($J)
10 Q
11 ;
12LKILL 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
13 K LRTHER,LRTSTS,LRWRD,RACNI,RAST,RPTR,OK,LRBLOOD,LRPARAM,LRPLASMA,LRSERUM,LRUNKNOW,LRURINE,LRPANEL,LRTM60,LRDT0,LRLABKY
14 Q
15 ; **The following routines are called by DVBCREQ1 **
16DDIS1 S DXNUM=$P(^DPT(DFN,.372,DVBCXJI,0),U,1),PCT=$P(^(0),U,2)
17 S DVBCSC=$P(^(0),U,3)
18 S DVBCDX=$S($D(^DIC(31,DXNUM)):$P(^(DXNUM,0),U,1),1:"Unknown")
19 S DXCOD=$S($D(^DIC(31,DXNUM)):$P(^(DXNUM,0),U,3),1:"Unknown")
20 W ?2,DVBCDX,?37,$J(PCT,3,0)," %",?50,$S(DVBCSC=1:"Yes",1:"No")
21 W ?58,DXCOD,!
22 I IOST?1"C-".E W !,"VA Form 21-2507" D TERM
23 Q
24 ;
25DDIS ;display rated disabilities
26 I '$D(^DPT(DFN,.372)) W !?25,"No rated disabilities on file",!! Q
27 W !?2,"Rated Disability",?37,"Percent",?50,"SC ?",?58,"Dx Code",! W ?2 F LINE=1:1:63 W "-"
28 W !!
29 F DVBCXJI=0:0 S DVBCXJI=$O(^DPT(DFN,.372,DVBCXJI)) Q:DVBCXJI="" D DDIS1 Q:($D(GETOUT))
30 W !!
31 Q
32 ;
33TST W ?3
34 F DA=0:0 S DA=$O(^DVB(396.4,"C",DA(1),DA)) Q:(DA="")!($D(GETOUT)) D CONTST
35 Q
36 ;
37CONTST K PRINT S TSTAT=$P(^DVB(396.4,DA,0),U,4)
38 S TST=$P(^DVB(396.4,DA,0),U,3)
39 S PRTNM=$S($D(^DVB(396.6,TST,0)):$P(^(0),U,2),1:"")
40 D TST1
41 Q
42 ;
43TST1 I $Y>(IOSL-3) W !,"VA Form 21-2507" I IOST?1"C-".E D TERM Q:($D(GETOUT))
44 S TSTA1=""
45 I $D(^DVB(396.4,DA,"CAN")) S TSTA1=$P(^DVB(396.4,DA,"CAN"),U,3)
46 I $D(^DVB(396.4,DA,"TRAN")) S X=$P(^DVB(396.4,DA,"TRAN"),U,3)
47 S:TSTA1]"" TSTA1=$P(^DVB(396.5,TSTA1,0),U,1) ;tsta1=cancellation reason
48 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:"")
49 I TSTAT="T" S X=$S($D(^DIC(4.2,+X,0)):$P(^(0),U,1),1:"unknown site") W " to ",$P(X,".",1)
50 W "; "
51 I $D(DVBAINSF) DO
52 .I +$P(^DVB(396.4,DA,0),U,11)>0 DO
53 ..I $Y>(IOSL-7) D BOT D:'$D(GETOUT) HDR^DVBCREQ1
54 ..I '$D(GETOUT) DO
55 ...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)
56 ...S TVAR(2,0)="0,3,0,2:1,0^Insufficient Remarks: "
57 ...D WR^DVBAUTL4("TVAR")
58 ...K TVAR
59 ...I $D(^DVB(396.4,DA,"INREM")) DO
60 ....K ^UTILITY($J,"W")
61 ....S DIWL=5,DIWF="NW"
62 ....F LPCNT=0:0 S LPCNT=$O(^DVB(396.4,DA,"INREM",LPCNT)) Q:LPCNT=""!($D(GETOUT)) DO ;**Loop Insufficient Remarks
63 .....S X=^DVB(396.4,DA,"INREM",LPCNT,0)
64 .....S:X="<" X=" <"
65 .....S X=$P(X,"<",1)
66 .....D ^DIWP ;**Print Insufficient Remarks
67 .....I $Y>(IOSL-8),$O(^DVB(396.4,DA,"INREM",LPCNT))]"" DO
68 ......D BOT D:'$D(GETOUT) HDR^DVBCREQ1,RMRK
69 ....D:'$D(GETOUT)&($O(^DVB(396.4,DA,"INREM",0))>0) ^DIWW
70 ...W !!
71 Q
72 ;
73TERM ; ** If output to CRT, display 'Continue' prompt **
74 S DIR(0)="F,O^^",DIR("A")="Enter [Return] to continue or ""^"" to exit"
75 K GETOUT D ^DIR S:$D(DTOUT)!($D(DUOUT)) GETOUT=1
76 I '$D(GETOUT) W @IOF K DIR,DIRUT
77 Q
78 ;
79BOT ;**Write form # at bottom
80 I IOST?1"C-".E F LPCNT1=$Y:1:(IOSL-6) W !
81 I IOST'?1"C-".E F LPCNT1=$Y:1:(IOSL-4) W !
82 W !,"VA Form 21-2507"
83 I IOST?1"C-".E D TERM
84 Q
85 ;
86RMRK ;** Write remarks continued at top of page
87 W !!?3,"Insufficient remarks, continued",!!
88 Q
Note: See TracBrowser for help on using the repository browser.