DVBCPRN1 ;ALB/GTS-557/THM-C&P FINAL REPORT PRINT ; 9/3/91 8:05 AM
;;2.7;AMIE;**31,193**;Apr 10, 1995;Build 84
;
PHYS S PHYS=$S($D(^DVB(396.4,DA,0)):$P(^(0),U,7),1:"")
Q
;
STEP2A S EXMNM=$S($D(^DVB(396.6,JI,0)):$P(^(0),U,1),1:"Unknown exam") I $D(AUTO),$D(XEXMNM),EXMNM'=XEXMNM Q ;print one exam on transcription
S EXHD="For "_EXMNM_" Exam" D HDR W "Examining provider: ",PHYS,!,"Examined on: " S Y=$P(^DVB(396.4,DA,0),U,6) X XDD W Y,! F LINE=1:1:80 W "="
W !!?2,"Examination results:",!! K NCN S EXSTAT=$P(^DVB(396.4,DA,0),U,4) I EXSTAT="X"!(EXSTAT="RX") W !!!!!?25,"This exam was CANCELLED by ",$S(EXSTAT="RX":"the RO.",1:"MAS."),!! Q
D STEP3
Q
;
STEP2 F DA=0:0 S DA=$O(^DVB(396.4,"C",DA(1),DA)) Q:DA="" S RO=+$P(^DVB(396.3,DA(1),0),U,3) Q:'$D(AUTO)&(DUZ(2)'=RO) S PG=0,JI=$P(^DVB(396.4,DA,0),U,3) D PHYS,STEP2A I $D(PRINT) D BOT K PRINT
;AJF;Request Status conversion
I '$D(AUTO) S %DT="TS",X="NOW" D ^%DT S DA=DA(1),CTIM=Y,DR="6////"_CTIM_";15////"_CTIM_";16////^S X=DUZ;17////5",DIE="^DVB(396.3,",DIC=DIE D ^DIE
Q
;
STEP3 K ^UTILITY($J,"W") S DIWL=1,DIWR=80,DIWF="NW" S OLDA=DA,OLDA1=DA(1)
F LINE=0:0 S LINE=$O(^DVB(396.4,OLDA,"RES",LINE)) Q:LINE="" S X=^DVB(396.4,OLDA,"RES",LINE,0) D ^DIWP,STEP3A
D ^DIWW S PRINT=1 S DA=OLDA,DA(1)=OLDA1 Q
;
STEP3A I $Y>(IOSL-11) D UP,NEXT,HDR W:$O(^DVB(396.4,OLDA,"RES",LINE))]"" !!,"Exam Results Continued",!!
Q
;
HDR S PG=PG+1 I PG>1 D HDR2^DVBCUTL2 Q
S:ZPR'="E" TOTTIME=$$PROCDAY^DVBCUTL2(DA(1))
S:ZPR="E" TOTTIME=$$INSFTME^DVBCUTA1(DA(1))
S OUTTIME="Processing time: "_TOTTIME
W @IOF
W !,"Date: ",DVBCDT(0),?(80-$L(PGHD)\2),PGHD,?71,"Page: ",PG,!?(80-$L(DVBCSITE)\2),DVBCSITE,!
W ?35,"** FINAL **",! W ?(80-$L(OUTTIME)\2),OUTTIME,!?(80-$L(EXHD)\2),EXHD,! F LNE=1:1:80 W "="
K LNE S:EXHD["AGENT ORANGE" DVBCAO=1 I EXHD'["AGENT ORANGE" K DVBCAO
D SSNOUT^DVBCUTIL
W !!?2,"Name: ",PNAM,?56,"SSN: ",DVBCSSNO,!?51,"C-Number: ",CNUM,!?56,"DOB: " S Y=DOB X XDD W Y,!?2,"Address: ",ADR1,! W:ADR2]"" ?11,ADR2,! W:ADR3]"" ?11,ADR3,!!
K DVBCSSNO
W !?2,"City,State,Zip+4: ",?48,"Res Phone: ",HOMPHON,!?5,CITY," ",STATE," ",ZIP,?48,"Bus Phone: ",BUSPHON,!
W !,"Entered active service: " S Y=EOD X XDD S:Y="" Y="Not specified" W Y,?40,"Last rating exam date: ",LREXMDT,! S Y=RAD X XDD S:Y="" Y="Not specified" W "Released active service: " W Y,!!,"Priority of exam: ",PRIO,!
F LNE=1:1:80 W "="
W ! Q
;
ZTSK S PG=0,AUTO=1 K ULINE
;$D(AUTO)=copy for review, Vet file after approval
I '$D(DT) S X="T" D ^%DT S DT=Y
S XDD=^DD("DD"),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:"Site name not in file")
S $P(ULINE,"_",70)="_",XEXMNM=EXMNM K EXMNM D VARS^DVBCUTIL,STEP2,BOT
I '$D(EDPRT) G KILL^DVBCUTIL
Q
;
UP F XIX=$Y:1:(IOSL-8) W !
Q
;
NEXT W !,"Continued on next page",!,"VA Form 2507"
Q
;
BOT I '$D(AUTO),$D(PRINT) D UP W ?7,"This exam has been reviewed and approved by the examining provider" W:$D(DVBCAO) !?27,"and signed by the veteran" W ".",!!,"VA Form 2507",! ;if for RO
I $D(AUTO),$D(PRINT) D UP W ?7," Approved by: ___________________________________ Date: _____________",!!
I $D(AUTO),$D(PRINT) W "Provider signature: ___________________________________ Date: _____________",!!,"VA Form 2507",! ;if file copy
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBCPRN1 3338 printed Dec 13, 2024@01:45:18 Page 2
DVBCPRN1 ;ALB/GTS-557/THM-C&P FINAL REPORT PRINT ; 9/3/91 8:05 AM
+1 ;;2.7;AMIE;**31,193**;Apr 10, 1995;Build 84
+2 ;
PHYS SET PHYS=$SELECT($DATA(^DVB(396.4,DA,0)):$PIECE(^(0),U,7),1:"")
+1 QUIT
+2 ;
STEP2A ;print one exam on transcription
SET EXMNM=$SELECT($DATA(^DVB(396.6,JI,0)):$PIECE(^(0),U,1),1:"Unknown exam")
IF $DATA(AUTO)
IF $DATA(XEXMNM)
IF EXMNM'=XEXMNM
QUIT
+1 SET EXHD="For "_EXMNM_" Exam"
DO HDR
WRITE "Examining provider: ",PHYS,!,"Examined on: "
SET Y=$PIECE(^DVB(396.4,DA,0),U,6)
XECUTE XDD
WRITE Y,!
FOR LINE=1:1:80
WRITE "="
+2 WRITE !!?2,"Examination results:",!!
KILL NCN
SET EXSTAT=$PIECE(^DVB(396.4,DA,0),U,4)
IF EXSTAT="X"!(EXSTAT="RX")
WRITE !!!!!?25,"This exam was CANCELLED by ",$SELECT(EXSTAT="RX":"the RO.",1:"MAS."),!!
QUIT
+3 DO STEP3
+4 QUIT
+5 ;
STEP2 FOR DA=0:0
SET DA=$ORDER(^DVB(396.4,"C",DA(1),DA))
if DA=""
QUIT
SET RO=+$PIECE(^DVB(396.3,DA(1),0),U,3)
if '$DATA(AUTO)&(DUZ(2)'=RO)
QUIT
SET PG=0
SET JI=$PIECE(^DVB(396.4,DA,0),U,3)
DO PHYS
DO STEP2A
IF $DATA(PRINT)
DO BOT
KILL PRINT
+1 ;AJF;Request Status conversion
+2 IF '$DATA(AUTO)
SET %DT="TS"
SET X="NOW"
DO ^%DT
SET DA=DA(1)
SET CTIM=Y
SET DR="6////"_CTIM_";15////"_CTIM_";16////^S X=DUZ;17////5"
SET DIE="^DVB(396.3,"
SET DIC=DIE
DO ^DIE
+3 QUIT
+4 ;
STEP3 KILL ^UTILITY($JOB,"W")
SET DIWL=1
SET DIWR=80
SET DIWF="NW"
SET OLDA=DA
SET OLDA1=DA(1)
+1 FOR LINE=0:0
SET LINE=$ORDER(^DVB(396.4,OLDA,"RES",LINE))
if LINE=""
QUIT
SET X=^DVB(396.4,OLDA,"RES",LINE,0)
DO ^DIWP
DO STEP3A
+2 DO ^DIWW
SET PRINT=1
SET DA=OLDA
SET DA(1)=OLDA1
QUIT
+3 ;
STEP3A IF $Y>(IOSL-11)
DO UP
DO NEXT
DO HDR
if $ORDER(^DVB(396.4,OLDA,"RES",LINE))]""
WRITE !!,"Exam Results Continued",!!
+1 QUIT
+2 ;
HDR SET PG=PG+1
IF PG>1
DO HDR2^DVBCUTL2
QUIT
+1 if ZPR'="E"
SET TOTTIME=$$PROCDAY^DVBCUTL2(DA(1))
+2 if ZPR="E"
SET TOTTIME=$$INSFTME^DVBCUTA1(DA(1))
+3 SET OUTTIME="Processing time: "_TOTTIME
+4 WRITE @IOF
+5 WRITE !,"Date: ",DVBCDT(0),?(80-$LENGTH(PGHD)\2),PGHD,?71,"Page: ",PG,!?(80-$LENGTH(DVBCSITE)\2),DVBCSITE,!
+6 WRITE ?35,"** FINAL **",!
WRITE ?(80-$LENGTH(OUTTIME)\2),OUTTIME,!?(80-$LENGTH(EXHD)\2),EXHD,!
FOR LNE=1:1:80
WRITE "="
+7 KILL LNE
if EXHD["AGENT ORANGE"
SET DVBCAO=1
IF EXHD'["AGENT ORANGE"
KILL DVBCAO
+8 DO SSNOUT^DVBCUTIL
+9 WRITE !!?2,"Name: ",PNAM,?56,"SSN: ",DVBCSSNO,!?51,"C-Number: ",CNUM,!?56,"DOB: "
SET Y=DOB
XECUTE XDD
WRITE Y,!?2,"Address: ",ADR1,!
if ADR2]""
WRITE ?11,ADR2,!
if ADR3]""
WRITE ?11,ADR3,!!
+10 KILL DVBCSSNO
+11 WRITE !?2,"City,State,Zip+4: ",?48,"Res Phone: ",HOMPHON,!?5,CITY," ",STATE," ",ZIP,?48,"Bus Phone: ",BUSPHON,!
+12 WRITE !,"Entered active service: "
SET Y=EOD
XECUTE XDD
if Y=""
SET Y="Not specified"
WRITE Y,?40,"Last rating exam date: ",LREXMDT,!
SET Y=RAD
XECUTE XDD
if Y=""
SET Y="Not specified"
WRITE "Released active service: "
WRITE Y,!!,"Priority of exam: ",PRIO,!
+13 FOR LNE=1:1:80
WRITE "="
+14 WRITE !
QUIT
+15 ;
ZTSK SET PG=0
SET AUTO=1
KILL ULINE
+1 ;$D(AUTO)=copy for review, Vet file after approval
+2 IF '$DATA(DT)
SET X="T"
DO ^%DT
SET DT=Y
+3 SET XDD=^DD("DD")
SET Y=DT
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:"Site name not in file")
+4 SET $PIECE(ULINE,"_",70)="_"
SET XEXMNM=EXMNM
KILL EXMNM
DO VARS^DVBCUTIL
DO STEP2
DO BOT
+5 IF '$DATA(EDPRT)
GOTO KILL^DVBCUTIL
+6 QUIT
+7 ;
UP FOR XIX=$Y:1:(IOSL-8)
WRITE !
+1 QUIT
+2 ;
NEXT WRITE !,"Continued on next page",!,"VA Form 2507"
+1 QUIT
+2 ;
BOT ;if for RO
IF '$DATA(AUTO)
IF $DATA(PRINT)
DO UP
WRITE ?7,"This exam has been reviewed and approved by the examining provider"
if $DATA(DVBCAO)
WRITE !?27,"and signed by the veteran"
WRITE ".",!!,"VA Form 2507",!
+1 IF $DATA(AUTO)
IF $DATA(PRINT)
DO UP
WRITE ?7," Approved by: ___________________________________ Date: _____________",!!
+2 ;if file copy
IF $DATA(AUTO)
IF $DATA(PRINT)
WRITE "Provider signature: ___________________________________ Date: _____________",!!,"VA Form 2507",!
+3 QUIT
