Routine: DVBCPRN1

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:"")

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

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

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",!!

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

UP F XIX=$Y:1:(IOSL-8) W !

NEXT W !,"Continued on next page",!,"VA Form 2507"

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

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBCPRN1   3338     printed  Apr 23, 2025@17:59:46                                                                                                                                                                                                    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

DVBCPRN1.m