Ignore:
Timestamp:
Dec 4, 2009, 12:11:15 AM (15 years ago)
Author:
George Lilly
Message:

revised back to 6/30/08 version

Location:
WorldVistAEHR/trunk/r/AUTOMATED_MED_INFO_EXCHANGE-DVBA-DVBC
Files:
2 edited

Legend:

Unmodified
Added
Removed

  • WorldVistAEHR/trunk/r/AUTOMATED_MED_INFO_EXCHANGE-DVBA-DVBC/DVBCREQ1.m

    r613 r623  
    1 DVBCREQ1        ;ALB/GTS-557/THM-NEW 2507 REQUEST PRINTING ; 5/25/91  11:36 AM
    2         ;;2.7;AMIE;**19,29,126**;Apr 10, 1995;Build 8
    3         ;
    4 START   S PGHD="COMPENSATION AND PENSION EXAM REQUEST",ROHD="Requested by "_RONAME,PG=0
    5         D HDR
    6         D SSNOUT^DVBCUTIL ;** Set the value of DVBCSSNO
    7         W !?2,"Name: ",PNAM,?56,"SSN: ",DVBCSSNO,!?51,"C-Number: ",CNUM,!?56,"DOB: " S Y=DOB X ^DD("DD") W Y,!?2,"Address: ",ADR1,! W:ADR2]"" ?11,ADR2,! W:ADR3]"" ?11,ADR3,!!
    8         W ?2,"City,State,Zip+4: ",?48,"Res Phone: ",HOMPHON,!?5,CITY,"  ",STATE,"  ",ZIP,?48,"Bus Phone: ",BUSPHON,!   ;I IOST?1"C-".E D CRTBOT G:$D(GETOUT) EXIT  ;DVBA/126 comment off this code
    9         I $D(^DPT(DFN,.121)) I $D(DTT) D    ;DVBA/126
    10         .Q:$P(DTT,U,9)=""!($P(DTT,U,9)="N")
    11         .I $P(DTT,U,7)'="" Q:$P(DTT,U,7)>DT
    12         .I $P(DTT,U,8)'="" Q:$P(DTT,U,8)<DT
    13         .W !?2,"Temporary Address: ",TAD1,! W:TAD2]"" ?21,TAD2,! W:TAD3]"" ?21,TAD3,!
    14         .W ?2,"City,State,Zip+4: ",?48,"Temporary Phone: ",!?5,TCITY,"  ",TST,"  ",TZIP,?51,TPHONE,!
    15         I IOST?1"C-".E D CRTBOT G:$D(GETOUT) EXIT  ;DVBA/126
    16         W !,"Entered active service: " S Y=EOD X ^DD("DD") S:Y="" Y="Not specified" W Y,?40,"Last rating exam date: ",LREXMDT,! S Y=RAD X ^DD("DD") S:Y="" Y="Not specified" W "Released active service: " W Y,!
    17         F LINE=1:1:80 W "="
    18         S TVAR(1,0)="0,0,0,2:1,0^** Priority of exam: "_PRIO
    19         D WR^DVBAUTL4("TVAR")
    20         K TVAR
    21         I $D(^DVB(396.3,DA(1),5)),(+$P(^DVB(396.3,DA(1),5),U,1)>0) DO
    22         .I $D(DVBAINSF),($D(^DVB(396.3,$P(^DVB(396.3,DA(1),5),U,1),0))) DO
    23         ..S Y=$P(^DVB(396.3,$P(^DVB(396.3,DA(1),5),U,1),0),U,5) X ^DD("DD")
    24         ..S TVAR(1,0)="0,0,0,0,0^Date original 2507 Reported to MAS: "_Y K Y
    25         ..D WR^DVBAUTL4("TVAR")
    26         ..K TVAR
    27         S TVAR(1,0)="0,0,0,3:2,0^Selected exams: "
    28         D WR^DVBAUTL4("TVAR")
    29         K TVAR
    30         D TST^DVBCUTL3 G:($D(GETOUT)) EXIT
    31         W !!!!! I IOST?1"C-".E D CRTBOT G:$D(GETOUT) EXIT
    32         W "Current Rated disabilities:",!! D DDIS^DVBCUTL3 G:($D(GETOUT)) EXIT
    33         W "Other Disabilities:",!!?2,OTHDIS,!?2,OTHDIS1,!?2,OTHDIS2,!!,"General remarks:",!!
    34         K ^UTILITY($J,"W")
    35         I IOST?1"C-".E D CRTBOT G:$D(GETOUT) EXIT
    36         F LINE=0:0 S LINE=$O(^DVB(396.3,DA(1),2,LINE)) Q:(LINE="")!($D(GETOUT))  S X=^(LINE,0),DIWL=1,DIWF="NW" D ^DIWP I $Y>(IOSL-7),$O(^DVB(396.3,DA(1),2,LINE))]"" D BOT D:'$D(GETOUT) HDR,RMRK
    37         D:('$D(GETOUT)) ^DIWW
    38         ; **  Exit TAG **
    39 EXIT    D:('$D(GETOUT)) BOT K GETOUT,LPCNT,DVBCDX,DVBCSC,DVBCSSNO,DTT,TAD1,TAD2,TAD3,TCITY,TST,TZIP,TPHONE Q
    40         ;
    41 HDR     S PG=PG+1 I '$D(ONE)!(($D(ONE))&(PG>1))!(IOST?1"C-".E) W @IOF
    42         W !,"Date: ",DVBCDT(0),?(80-$L(PGHD)\2),PGHD,?71,"Page: ",PG,! S PRTDIV=$S($D(^DG(40.8,XDIV,0)):$P(^(0),U,1),1:"Unknown division") S PRTDIV="For "_PRTDIV_" Medical Center Division at "_$$SITE^DVBCUTL4
    43         W ?(80-$L(PRTDIV)\2),PRTDIV
    44         W !! S Y=$P(^DVB(396.3,DA(1),0),U,22) I Y]"" S Z="*** Transferred from ",Z=Z_$S($D(^DIC(4.2,+Y,0)):$P(^(0),U,1),1:"unknown site")_" ***" W ?(80-$L(Z)\2),Z,!
    45         W ?(80-$L(ROHD)\2),ROHD,! S RQ="Date Requested: ",Y=DTRQ X ^DD("DD") S RQ=RQ_Y W ?(80-$L(RQ)\2),RQ,! F XLN=1:1:80 W "="
    46         K XLN Q
    47         ;
    48 CRTBOT  ;  ** Write form number at bottom of CRT **
    49         I $P(^DVB(396.3,DA(1),0),U,23)="Y" W !?20,"** Claim folder review will be required **",!
    50         F LPCNT=$Y:1:(IOSL-7) W !
    51         W !,"VA Form 21-2507"
    52         D TERM^DVBCUTL3
    53         Q
    54         ;
    55 BOT     I $P(^DVB(396.3,DA(1),0),U,23)="Y" W !?20,"** Claim folder review will be required **",!
    56         I IOST?1"C-".E F LPCNT=$Y:1:(IOSL-6) W !
    57         I IOST'?1"C-".E F LPCNT=$Y:1:(IOSL-4) W !
    58         W !,"VA Form 21-2507"
    59         I IOST?1"C-".E D TERM^DVBCUTL3
    60         Q
    61         ;
    62 RMRK    W !?2,"Name: ",PNAM,?56,"SSN: ",DVBCSSNO
    63         W ! F XLN=1:1:80 W "="
    64         W !!,"General remarks (continued):",!!
    65         Q
     1DVBCREQ1 ;ALB/GTS-557/THM-NEW 2507 REQUEST PRINTING ; 5/25/91  11:36 AM
     2 ;;2.7;AMIE;**19,29**;Apr 10, 1995
     3 ;
     4START S PGHD="COMPENSATION AND PENSION EXAM REQUEST",ROHD="Requested by "_RONAME,PG=0
     5 D HDR
     6 D SSNOUT^DVBCUTIL ;** Set the value of DVBCSSNO
     7 W !?2,"Name: ",PNAM,?56,"SSN: ",DVBCSSNO,!?51,"C-Number: ",CNUM,!?56,"DOB: " S Y=DOB X ^DD("DD") W Y,!?2,"Address: ",ADR1,! W:ADR2]"" ?11,ADR2,! W:ADR3]"" ?11,ADR3,!!
     8 W !?2,"City,State,Zip+4: ",?48,"Res Phone: ",HOMPHON,!?5,CITY,"  ",STATE,"  ",ZIP,?48,"Bus Phone: ",BUSPHON,! I IOST?1"C-".E D CRTBOT G:$D(GETOUT) EXIT
     9 W !,"Entered active service: " S Y=EOD X ^DD("DD") S:Y="" Y="Not specified" W Y,?40,"Last rating exam date: ",LREXMDT,! S Y=RAD X ^DD("DD") S:Y="" Y="Not specified" W "Released active service: " W Y,!
     10 F LINE=1:1:80 W "="
     11 S TVAR(1,0)="0,0,0,2:1,0^** Priority of exam: "_PRIO
     12 D WR^DVBAUTL4("TVAR")
     13 K TVAR
     14 I $D(^DVB(396.3,DA(1),5)),(+$P(^DVB(396.3,DA(1),5),U,1)>0) DO
     15 .I $D(DVBAINSF),($D(^DVB(396.3,$P(^DVB(396.3,DA(1),5),U,1),0))) DO
     16 ..S Y=$P(^DVB(396.3,$P(^DVB(396.3,DA(1),5),U,1),0),U,5) X ^DD("DD")
     17 ..S TVAR(1,0)="0,0,0,0,0^Date original 2507 Reported to MAS: "_Y K Y
     18 ..D WR^DVBAUTL4("TVAR")
     19 ..K TVAR
     20 S TVAR(1,0)="0,0,0,3:2,0^Selected exams: "
     21 D WR^DVBAUTL4("TVAR")
     22 K TVAR
     23 D TST^DVBCUTL3 G:($D(GETOUT)) EXIT
     24 W !!!!! I IOST?1"C-".E D CRTBOT G:$D(GETOUT) EXIT
     25 W "Current Rated disabilities:",!! D DDIS^DVBCUTL3 G:($D(GETOUT)) EXIT
     26 W "Other Disabilities:",!!?2,OTHDIS,!?2,OTHDIS1,!?2,OTHDIS2,!!,"General remarks:",!!
     27 K ^UTILITY($J,"W")
     28 I IOST?1"C-".E D CRTBOT G:$D(GETOUT) EXIT
     29 F LINE=0:0 S LINE=$O(^DVB(396.3,DA(1),2,LINE)) Q:(LINE="")!($D(GETOUT))  S X=^(LINE,0),DIWL=1,DIWF="NW" D ^DIWP I $Y>(IOSL-7),$O(^DVB(396.3,DA(1),2,LINE))]"" D BOT D:'$D(GETOUT) HDR,RMRK
     30 D:('$D(GETOUT)) ^DIWW
     31 ; **  Exit TAG **
     32EXIT D:('$D(GETOUT)) BOT K GETOUT,LPCNT,DVBCDX,DVBCSC,DVBCSSNO Q
     33 ;
     34HDR S PG=PG+1 I '$D(ONE)!(($D(ONE))&(PG>1))!(IOST?1"C-".E) W @IOF
     35 W !,"Date: ",DVBCDT(0),?(80-$L(PGHD)\2),PGHD,?71,"Page: ",PG,! S PRTDIV=$S($D(^DG(40.8,XDIV,0)):$P(^(0),U,1),1:"Unknown division") S PRTDIV="For "_PRTDIV_" Medical Center Division at "_$$SITE^DVBCUTL4
     36 W ?(80-$L(PRTDIV)\2),PRTDIV
     37 W !! S Y=$P(^DVB(396.3,DA(1),0),U,22) I Y]"" S Z="*** Transferred from ",Z=Z_$S($D(^DIC(4.2,+Y,0)):$P(^(0),U,1),1:"unknown site")_" ***" W ?(80-$L(Z)\2),Z,!
     38 W ?(80-$L(ROHD)\2),ROHD,! S RQ="Date Requested: ",Y=DTRQ X ^DD("DD") S RQ=RQ_Y W ?(80-$L(RQ)\2),RQ,! F XLN=1:1:80 W "="
     39 K XLN Q
     40 ;
     41CRTBOT ;  ** Write form number at bottom of CRT **
     42 I $P(^DVB(396.3,DA(1),0),U,23)="Y" W !?20,"** Claim folder review will be required **",!
     43 F LPCNT=$Y:1:(IOSL-7) W !
     44 W !,"VA Form 21-2507"
     45 D TERM^DVBCUTL3
     46 Q
     47 ;
     48BOT I $P(^DVB(396.3,DA(1),0),U,23)="Y" W !?20,"** Claim folder review will be required **",!
     49 I IOST?1"C-".E F LPCNT=$Y:1:(IOSL-6) W !
     50 I IOST'?1"C-".E F LPCNT=$Y:1:(IOSL-4) W !
     51 W !,"VA Form 21-2507"
     52 I IOST?1"C-".E D TERM^DVBCUTL3
     53 Q
     54 ;
     55RMRK W !?2,"Name: ",PNAM,?56,"SSN: ",DVBCSSNO
     56 W ! F XLN=1:1:80 W "="
     57 W !!,"General remarks (continued):",!!
     58 Q

  • WorldVistAEHR/trunk/r/AUTOMATED_MED_INFO_EXCHANGE-DVBA-DVBC/DVBCUTIL.m

    r613 r623  
    1 DVBCUTIL        ;ALB/GTS-557/THM;C&P UTILITY ROUTINE ; 4/26/91  11:16 AM
    2         ;;2.7;AMIE;**17,126**;Apr 10, 1995;Build 8
    3 KILL    ;common exit
    4         D ^%ZISC I $D(FF),'$D(ZTQUEUED) W @FF,!!
    5         K %DT,ADR1,ADR2,ADR3,BDTRQ,BUSPHON,CITY,CNDCT,CNUM,DFN,DIW,DIWF,DIWL,DIWR,DIWT,DN,DOB,DTA,DTRQ,DX,DXCOD,DXNUM,EDTRQ,HOMPHON,I,LINE,MDTRM,NAME,OTHDIS,PCT,PG,PGHD,POP,PRINT,REQN,RO,ROHD,RONAME,RQ,SC,D,DIE,ONE,DVBCNEW,LN,FEXM,PRIO,DTB
    6         K SEX,SSN,STATE,TST,X,Y,Z,JI,JII,ZIP,JJ,KJX,D0,D1,DA,DI,DIC,DIPGM,DLAYGO,DQ,DWLW,HD,HD1,HD2,J,ONFILE,CTIM,JJ,C,DIZ,DPTSZ,STAT,JDT,JY,TSTDT,DIYS,EXAM,DR,REQDT,ELIG,INCMP,PRDSV,WARD,ADD1,ADD2,CNTY,PG,OLDDA,DIRUT,DUOUT
    7         K DVBCCNT,TNAM,DIR,TEMP,SWITCH,EDTA,RAD,EOD,%T,STATUS,XX,XDD,OLDA,OLDA1
    8         K DTTRNSC,ZIP4,DVBAINSF,DTT,TAD1,TAD2,TAD3,TCITY,TST,TZIP,TPHONE
    9         G KILL^DVBCUTL2
    10         ;
    11 DICW    ;used on ^DIC lookups only
    12         W ! S TSTDT=$P(^(0),U,2),RO=$P(^(0),U,3),STAT=$P(^(0),U,18),RONAME=$S($D(^DIC(4,+RO,0)):$P(^(0),U,1),1:"Unknown RO") D DICW1
    13         W ! Q
    14         ;
    15 DICW1   F JY=0:0 S JY=$O(^DVB(396.4,"C",+Y,JY)) Q:JY=""  S EXAM=$P(^DVB(396.4,+JY,0),U,3),EXAM=$S($D(^DVB(396.6,EXAM,0)):$P(^(0),U,1),1:"Unknown exam") D DICW2
    16         Q
    17         ;
    18 DICW2   W ?3,EXAM," (",$$FMTE^XLFDT(TSTDT,"5DZ")," by ",RONAME,")",!
    19         Q
    20         ;
    21 VARS    S DTA=^DVB(396.3,DA,0),DFN=$P(DTA,U,1),(NAME,PNAM)=$P(^DPT(DFN,0),U,1),DOB=$P(^(0),U,3),SEX=$P(^(0),U,2),SSN=$P(^(0),U,9),CNUM=$S($D(^DPT(DFN,.31)):$P(^(.31),U,3),1:"Unknown"),DTRQ=$P(DTA,U,2)
    22         S RO=$P(DTA,U,3),FEXM=$P(DTA,U,9) S:RO="" RO=0 S RONAME=$S($D(^DIC(4,RO,0)):$P(^(0),U,1),1:"Unknown")
    23         S REQN=$P(DTA,U,4),REQN=$S($D(^VA(200,+REQN,0)):$P(^(0),U,1),1:"Unknown"),OTHDIS=$P(DTA,U,11) I $D(^DVB(396.3,DA,1)) S OTHDIS1=$P(^(1),U,9),OTHDIS2=$P(^(1),U,10)
    24         S ZPR=$P(DTA,U,10),PRIO=$S(ZPR="T":"Terminal",ZPR="P":"Prisoner of war",ZPR="OS":"Original SC",ZPR="ON":"Original NSC",ZPR="I":"Increase",ZPR="R":"Review",ZPR="OTR":"Other",ZPR="E":"Inadequate exam",1:"Unknown")
    25         K DVBAINSF S:ZPR="E" DVBAINSF=""
    26         S (ADR1,ADR2,ADR3,CITY,STATE,ZIP)=""
    27         I $D(^DPT(DFN,.11)) S DTA=^DPT(DFN,.11),ADR1=$P(DTA,U,1),ADR2=$P(DTA,U,2),ADR3=$P(DTA,U,3),CITY=$P(DTA,U,4),ZIP=$P(DTA,U,12) S:ZIP'="" ZIP=$S($L(ZIP)>5:$E(ZIP,1,5)_"-"_$E(ZIP,6,9),1:ZIP) I ZIP="" S ZIP="No Zip"
    28         S CITY=$S(CITY]"":CITY,1:"Unknown") S STATE=$P(DTA,U,5) I STATE]"" S STATE=$S($D(^DIC(5,STATE,0)):$P(^(0),U,1),1:"Unknown")
    29         S (HOMPHON,BUSPHON)="Unknown" I $D(^DPT(DFN,.13)) S HOMPHON=$P(^(.13),U,1),BUSPHON=$P(^(.13),U,2)
    30         I $D(^DPT(DFN,.121)) D   ;DVBA/126 added
    31         .S (DTT,TAD1,TAD2,TAD3,TCITY,TST,TZIP,TPHONE)=""
    32         .S DTT=^DPT(DFN,.121)
    33         .S TAD1=$P(DTT,U,1),TAD2=$P(DTT,U,2),TAD3=$P(DTT,U,3),TCITY=$P(DTT,U,4)
    34         .S TZIP=$P(DTT,U,12) S:TZIP'="" TZIP=$S($L(TZIP)>5:$E(TZIP,1,5)_"-"_$E(TZIP,6,9),1:TZIP) I TZIP="" S TZIP="No Zip"
    35         .S TCITY=$S(TCITY]"":TCITY,1:"Unknown") S TST=$P(DTT,U,5) I TST]"" S TST=$S($D(^DIC(5,TST,0)):$P(^(0),U,1),1:"Unknown")
    36         .S TPHONE=$P(DTT,U,10) S:TPHONE="" TPHONE="Unknown"
    37         S EDTA=$S($D(^DPT(DFN,.32)):^(.32),1:""),EOD=$P(EDTA,U,6),RAD=$P(EDTA,U,7),Y=$S($D(^DVB(396.3,DA,1)):$P(^(1),U,7),1:"") X ^DD("DD") S LREXMDT=Y
    38         Q
    39         ;
    40 HDR     W @FF,?(IOM-$L(HD2)\2),HD2,!!!?5,"Veteran name: ",PNAM,?45,"SSN: ",SSN,!?40,"C-NUMBER: ",CNUM,!!,"Exams on this request:",!!
    41         S JII=""
    42         F JIJ=0:0 S JII=$O(^TMP($J,JII)) Q:JII=""  S XST=$P(^TMP($J,JII),U,1) W JII,", ",$S(XST="C":"Completed",XST="RX":"Cancelled by RO",XST="X":"Cancelled by MAS",XST="T":"Transferred",1:"Open"),", " I $X>30 W !
    43         Q
    44         ;
    45 ADDR    S (ADD1,ADD2,CITY,CNTY,STATE,ZIP)=""
    46         I $D(^DPT(DFN,.11)) S DTA=^(.11),ADD1=$P(DTA,U,1),ADD2=$P(DTA,U,2),CITY=$P(DTA,U,4),STATE=$P(DTA,U,5),ZIP=$P(DTA,U,12),CNTY=$P(DTA,U,7)
    47         S:ZIP'="" ZIP=$S($L(ZIP)>5:$E(ZIP,1,5)_"-"_$E(ZIP,6,9),1:ZIP)
    48         S CNTY=$S($D(^DIC(5,+STATE,1,+CNTY,0)):$P(^(0),U,1),1:"Unknown")
    49         S STATE=$S($D(^DIC(5,+STATE,0)):$P(^(0),U,1),1:"Unknown")
    50         W !!?0,"Address: ",?9,ADD1,! W:ADD2]"" ?9,ADD2,! W ?0,"City:",?9,CITY,"  ",STATE,"  ",ZIP,!?0,"County:",?9,CNTY,!!
    51         S PRDSV=$S($D(^DPT(DFN,.32)):$P(^(.32),U,3),1:"") I PRDSV]"" S PRDSV=$P(^DIC(21,PRDSV,0),U,1)
    52         W "Period of service: ",PRDSV,!
    53         S ELIG="",INCMP=0
    54         W ?0,"Eligibility data:" I $D(^DPT(DFN,.36)),$P(^(.36),U,1)]"" S ELIG=$S($D(^DIC(8,+^(.36),0)):$P(^(0),U,6),1:"")
    55         I ELIG]"",$D(^DPT(DFN,.361)),^(.361)]"" S ELIG=ELIG_" ("_$S($P(^(.361),U,1)="P":"Pend ver",$P(^(.361),U,1)="R":"Pend re-verif",$P(^(.361),U,1)="V":"Verified",1:"Not verified")_")"
    56         I $D(^DPT(DFN,.29)),$P(^(.29),U,1)]"" S INCMP=1
    57         I $D(^DPT(DA,.293)),$P(^(.293),U,1)=1 S INCMP=1
    58         W ?19,ELIG_$S(ELIG]"":", ",1:"")_$S(INCMP=1:"Incompetent",1:""),!
    59         Q
    60         ;
    61 SSNSHRT ;  ** Set SSN in the Format '123 45 6789' **
    62         K DVBCSSNO
    63         S DVBCSSNO=$E(SSN,1,3)_" "_$E(SSN,4,5)_" "_$E(SSN,6,9)
    64         Q
    65         ;
    66 SSNOUT  ;  ** Set SSN in the Format '123 45 6789 (Z6789) **
    67         D SSNSHRT
    68         S DVBCSSNO=DVBCSSNO_" ("_$E(PNAM)_$E(SSN,6,9)_")"
    69         Q
     1DVBCUTIL ;ALB/GTS-557/THM;C&P UTILITY ROUTINE ; 4/26/91  11:16 AM
     2 ;;2.7;AMIE;**17**;Apr 10, 1995
     3KILL ;common exit
     4 D ^%ZISC I $D(FF),'$D(ZTQUEUED) W @FF,!!
     5 K %DT,ADR1,ADR2,ADR3,BDTRQ,BUSPHON,CITY,CNDCT,CNUM,DFN,DIW,DIWF,DIWL,DIWR,DIWT,DN,DOB,DTA,DTRQ,DX,DXCOD,DXNUM,EDTRQ,HOMPHON,I,LINE,MDTRM,NAME,OTHDIS,PCT,PG,PGHD,POP,PRINT,REQN,RO,ROHD,RONAME,RQ,SC,D,DIE,ONE,DVBCNEW,LN,FEXM,PRIO,DTB
     6 K SEX,SSN,STATE,TST,X,Y,Z,JI,JII,ZIP,JJ,KJX,D0,D1,DA,DI,DIC,DIPGM,DLAYGO,DQ,DWLW,HD,HD1,HD2,J,ONFILE,CTIM,JJ,C,DIZ,DPTSZ,STAT,JDT,JY,TSTDT,DIYS,EXAM,DR,REQDT,ELIG,INCMP,PRDSV,WARD,ADD1,ADD2,CNTY,PG,OLDDA,DIRUT,DUOUT
     7 K DVBCCNT,TNAM,DIR,TEMP,SWITCH,EDTA,RAD,EOD,%T,STATUS,XX,XDD,OLDA,OLDA1
     8 K DTTRNSC,ZIP4,DVBAINSF
     9 G KILL^DVBCUTL2
     10 ;
     11DICW ;used on ^DIC lookups only
     12 W ! S TSTDT=$P(^(0),U,2),RO=$P(^(0),U,3),STAT=$P(^(0),U,18),RONAME=$S($D(^DIC(4,+RO,0)):$P(^(0),U,1),1:"Unknown RO") D DICW1
     13 W ! Q
     14 ;
     15DICW1 F JY=0:0 S JY=$O(^DVB(396.4,"C",+Y,JY)) Q:JY=""  S EXAM=$P(^DVB(396.4,+JY,0),U,3),EXAM=$S($D(^DVB(396.6,EXAM,0)):$P(^(0),U,1),1:"Unknown exam") D DICW2
     16 Q
     17 ;
     18DICW2 W ?3,EXAM," (",$$FMTE^XLFDT(TSTDT,"5DZ")," by ",RONAME,")",!
     19 Q
     20 ;
     21VARS S DTA=^DVB(396.3,DA,0),DFN=$P(DTA,U,1),(NAME,PNAM)=$P(^DPT(DFN,0),U,1),DOB=$P(^(0),U,3),SEX=$P(^(0),U,2),SSN=$P(^(0),U,9),CNUM=$S($D(^DPT(DFN,.31)):$P(^(.31),U,3),1:"Unknown"),DTRQ=$P(DTA,U,2)
     22 S RO=$P(DTA,U,3),FEXM=$P(DTA,U,9) S:RO="" RO=0 S RONAME=$S($D(^DIC(4,RO,0)):$P(^(0),U,1),1:"Unknown")
     23 S REQN=$P(DTA,U,4),REQN=$S($D(^VA(200,+REQN,0)):$P(^(0),U,1),1:"Unknown"),OTHDIS=$P(DTA,U,11) I $D(^DVB(396.3,DA,1)) S OTHDIS1=$P(^(1),U,9),OTHDIS2=$P(^(1),U,10)
     24 S ZPR=$P(DTA,U,10),PRIO=$S(ZPR="T":"Terminal",ZPR="P":"Prisoner of war",ZPR="OS":"Original SC",ZPR="ON":"Original NSC",ZPR="I":"Increase",ZPR="R":"Review",ZPR="OTR":"Other",ZPR="E":"Inadequate exam",1:"Unknown")
     25 K DVBAINSF S:ZPR="E" DVBAINSF=""
     26 S (ADR1,ADR2,ADR3,CITY,STATE,ZIP)=""
     27 I $D(^DPT(DFN,.11)) S DTA=^DPT(DFN,.11),ADR1=$P(DTA,U,1),ADR2=$P(DTA,U,2),ADR3=$P(DTA,U,3),CITY=$P(DTA,U,4),ZIP=$P(DTA,U,12) S:ZIP'="" ZIP=$S($L(ZIP)>5:$E(ZIP,1,5)_"-"_$E(ZIP,6,9),1:ZIP) I ZIP="" S ZIP="No Zip"
     28 S CITY=$S(CITY]"":CITY,1:"Unknown") S STATE=$P(DTA,U,5) I STATE]"" S STATE=$S($D(^DIC(5,STATE,0)):$P(^(0),U,1),1:"Unknown")
     29 S (HOMPHON,BUSPHON)="Unknown" I $D(^DPT(DFN,.13)) S HOMPHON=$P(^(.13),U,1),BUSPHON=$P(^(.13),U,2)
     30 S EDTA=$S($D(^DPT(DFN,.32)):^(.32),1:""),EOD=$P(EDTA,U,6),RAD=$P(EDTA,U,7),Y=$S($D(^DVB(396.3,DA,1)):$P(^(1),U,7),1:"") X ^DD("DD") S LREXMDT=Y
     31 Q
     32 ;
     33HDR W @FF,?(IOM-$L(HD2)\2),HD2,!!!?5,"Veteran name: ",PNAM,?45,"SSN: ",SSN,!?40,"C-NUMBER: ",CNUM,!!,"Exams on this request:",!!
     34 S JII=""
     35 F JIJ=0:0 S JII=$O(^TMP($J,JII)) Q:JII=""  S XST=$P(^TMP($J,JII),U,1) W JII,", ",$S(XST="C":"Completed",XST="RX":"Cancelled by RO",XST="X":"Cancelled by MAS",XST="T":"Transferred",1:"Open"),", " I $X>30 W !
     36 Q
     37 ;
     38ADDR S (ADD1,ADD2,CITY,CNTY,STATE,ZIP)=""
     39 I $D(^DPT(DFN,.11)) S DTA=^(.11),ADD1=$P(DTA,U,1),ADD2=$P(DTA,U,2),CITY=$P(DTA,U,4),STATE=$P(DTA,U,5),ZIP=$P(DTA,U,12),CNTY=$P(DTA,U,7)
     40 S:ZIP'="" ZIP=$S($L(ZIP)>5:$E(ZIP,1,5)_"-"_$E(ZIP,6,9),1:ZIP)
     41 S CNTY=$S($D(^DIC(5,+STATE,1,+CNTY,0)):$P(^(0),U,1),1:"Unknown")
     42 S STATE=$S($D(^DIC(5,+STATE,0)):$P(^(0),U,1),1:"Unknown")
     43 W !!?0,"Address: ",?9,ADD1,! W:ADD2]"" ?9,ADD2,! W ?0,"City:",?9,CITY,"  ",STATE,"  ",ZIP,!?0,"County:",?9,CNTY,!!
     44 S PRDSV=$S($D(^DPT(DFN,.32)):$P(^(.32),U,3),1:"") I PRDSV]"" S PRDSV=$P(^DIC(21,PRDSV,0),U,1)
     45 W "Period of service: ",PRDSV,!
     46 S ELIG="",INCMP=0
     47 W ?0,"Eligibility data:" I $D(^DPT(DFN,.36)),$P(^(.36),U,1)]"" S ELIG=$S($D(^DIC(8,+^(.36),0)):$P(^(0),U,6),1:"")
     48 I ELIG]"",$D(^DPT(DFN,.361)),^(.361)]"" S ELIG=ELIG_" ("_$S($P(^(.361),U,1)="P":"Pend ver",$P(^(.361),U,1)="R":"Pend re-verif",$P(^(.361),U,1)="V":"Verified",1:"Not verified")_")"
     49 I $D(^DPT(DFN,.29)),$P(^(.29),U,1)]"" S INCMP=1
     50 I $D(^DPT(DA,.293)),$P(^(.293),U,1)=1 S INCMP=1
     51 W ?19,ELIG_$S(ELIG]"":", ",1:"")_$S(INCMP=1:"Incompetent",1:""),!
     52 Q
     53 ;
     54SSNSHRT ;  ** Set SSN in the Format '123 45 6789' **
     55 K DVBCSSNO
     56 S DVBCSSNO=$E(SSN,1,3)_" "_$E(SSN,4,5)_" "_$E(SSN,6,9)
     57 Q
     58 ;
     59SSNOUT ;  ** Set SSN in the Format '123 45 6789 (Z6789) **
     60 D SSNSHRT
     61 S DVBCSSNO=DVBCSSNO_" ("_$E(PNAM)_$E(SSN,6,9)_")"
     62 Q
Note: See TracChangeset for help on using the changeset viewer.