DGOVBC1 ;ALB/MRL - VBC OUTPUT ; 12 FEB 87
;;5.3;Registration;**162,489**;Aug 13, 1993
N VAPA
K DGLN S $P(DGLN," ",80)="",DGU="UNKNOWN",DGPP=""
F DGPP1=0:0 S DGPP=$O(^UTILITY($J,"DGOVBC",DGPP)) Q:(DGPP="")!($G(ZTSTOP)=1) S DFN=^UTILITY($J,"DGOVBC",DGPP) D DIS,ENDREP^DGUTL
Q K DGCA,I,DGX,X,Y,%DT,DGFR,DGHD,DGHD1,DGHOW,DGIOM,DGLIN,DGLN,DGPP,DGPP1,DGTO,DGU,DGVAR,DIC,DFN,DGCT,DGDFN,DGP,DGPGM,ZTSTOP,^UTILITY($J,"DGOVBC") D CLOSE^DGUTQ Q
G Q^DGOVBC2
DIS I $$FIRST^DGUTL Q
D NOW^%DTC S Y=$E(%,1,12) W !,"VETERANS ASSISTANCE UNIT RECORD",?53,"PRINTED: ",$$FMTE^XLFDT(Y,1),?DGHD1,DGHD,!,DGLIN,! K Y
D DEM^VADPT D L W !,"1. Patient Name: ",$S(VADM(1)]"":VADM(1),1:"UNSPECIFIED PATIENT #"_DFN),?55,"| 2. DOB: ",$P(VADM(3),"^",2)
D PID^VADPT6 W ?80,"| 3. PT ID: ",$S(VA("PID"):VA("PID"),1:DGU),?106,"| 4. Claim #: " S DGMS=$S(VADM(10):$P(VADM(10),"^",2),1:DGU) K VA,VADM D ELIG^VADPT W $S(VAEL(7):VAEL(7),1:DGU),! S DGSC=+VAEL(3),DGMT=$P(VAEL(9),"^",2) K VAEL
W "_______________________________________________________|________________________|_________________________|_______________________"
D ADD^VADPT,A W !,"5. Address Information [Street, City, State, Zip Code]:" F I=0:0 S I=$O(DGA(I)) Q:'I W:I>1 ! W ?57,DGA(I),!
I VAPA(12)=1 D
.D L
.D AC W !,"5A. Confidential Address Information [Street, City, State, Zip Code]:" F I=0:0 S I=$O(DGA(I)) Q:'I W:I>1 ! W ?57,DGA(I)
K DGA W ! D SVC^VADPT,L W !,"6. Service Record",?35,"Service #",?55,"Entry Date",?75,"Separation Date",?108,"Discharge Type"
W $C(13)," ","______________",$E(DGLN,1,18),"_________",$E(DGLN,1,11),"__________",$E(DGLN,1,10),"_______________",$E(DGLN,1,18),"______________" S DGPOW=VASV(4)
F I=6:1:8 I VASV(I) W !?3,$S(VASV(I,1):$P(VASV(I,1),"^",2),1:DGU),?35,$S($L(VASV(I,2)):VASV(I,2),1:DGU),?55,$S('VASV(I,4):DGU,1:$P(VASV(I,4),"^",2)),?75,$S('VASV(I,5):DGU,1:$P(VASV(I,5),"^",2)),?108,$S(VASV(I,3):$P(VASV(I,3),"^",2),1:DGU)
K VASV W ! D L S DGCT=0 F I=0:0 S I=$O(^DGPM("ATID1",DFN,I)) Q:'I!(DGCT=2) F DGCA=0:0 S DGCA=$O(^DGPM("ATID1",DFN,I,DGCA)) Q:'DGCA!(DGCT=2) I $D(^DGPM(DGCA,0)) S DGCT=DGCT+1,DGADM(DGCT)=^(0),DGADM(DGCT,4)=$P(^(0),"^",12)
S DGSCOND=0 W !,"7. Admission Date" I 'DGCT W ": NO ADMISSIONS ON FILE FOR THIS APPLICANT." G ^DGOVBC2
W ?20,"Admission Type",?55,"Ward",?70,"Admitting Diagnosis",?105,"Admission Authority"
W $C(13)," ","______________"," ","______________",$E(DGLN,1,21),"____",$E(DGLN,1,11),"___________________",$E(DGLN,1,16),"___________________"
F I=1:1:DGCT S DGD=DGADM(I),DGD1=DGADM(I,4) D AS W !?3,DGD(1),?20,DGD(2),?55,$E(DGD(3),1,10),?70,DGD(4),?105,$E(DGD(5),1,25)
D H^DGUTL S DGT=DGTIME K DGTIME D ^DGINPW W !?4,"NOTE: ",$S('DG1:"NOT CURRENTLY AN INPATIENT.",1:$S($D(^DIC(42,+DG1,0)):"CURRENTLY AN INPATIENT ON WARD '"_$P(^(0),"^",1)_"'."),1:"INPATIENT ON UNKNOWN WARD.")
I DGSCOND W !?4,"NOTE: Asterisk [*] indicates admission for Service Connected Condition."
K DGSCOND G ^DGOVBC2
L F DGL=1:1:$S($D(IOM):(IOM-2),1:130) W "_"
Q
PT F I=0,.11,.15,.3,.31,.32,.36,.361,.362,.52,"VET" S DGP(I)=$S($D(^DPT(DFN,I)):^(I),1:"")
S DGSC=$S($P(DGP(.3),"^",1)="Y":1,1:0) Q
A S DGA=1 F I=1:1:3 Q:'$L(VAPA(I)) S:I=3 DGA(2)=DGA(2)_", "_VAPA(I) S:DGA<3 DGA(I)=VAPA(I),DGA=DGA+1
I VAPA(1)']"" S DGA(1)="STREET ADDRESS UNKNOWN",DGA=2
S DGA(DGA)=$S($L(VAPA(4))&(VAPA(5)):VAPA(4)_", "_$P(VAPA(5),"^",2),$L(VAPA(4)):VAPA(4),VAPA(5):$P(VAPA(5),"^",2),1:"CITY STATE UNKNOWN")
S:$L(DGA(DGA)) DGA(DGA)=DGA(DGA)_" "_VAPA(6)
I VAPA(12)=0 K I,J
Q
AC ;Formatting Confidential Address Information
K DGA
I VAPA(12)=1 D
.N DGASEQ,SEQ
.S DGA=13 F I=13:1:15 Q:'$L(VAPA(I)) S:I=15 DGA(14)=DGA(14)_", "_VAPA(I) S:DGA<15 DGA(I)=VAPA(I),DGA=DGA+1
.S DGA(19)="______________________________________________"
.S DGA(20)="Confidential Start Date: "_$P(VAPA(20),"^",2)
.S DGA(21)="Confidential End Date: "_$P(VAPA(21),"^",2)
.S DGA(22)="Confidential Address Categories:"
.S SEQ="",DGASEQ=23 F S SEQ=$O(VAPA(22,SEQ)) Q:SEQ="" D
..I $P(VAPA(22,SEQ),"^",3)="Y" S DGA(DGASEQ)=$P(VAPA(22,SEQ),"^",2),DGASEQ=DGASEQ+1
.I VAPA(13)']"" S DGA(1)="STREET ADDRESS UNKNOWN",DGA=2
.S DGA(DGA)=$S($L(VAPA(16))&(VAPA(17)):VAPA(16)_", "_$P(VAPA(17),"^",2),$L(VAPA(16)):VAPA(16),VAPA(17):$P(VAPA(17),"^",2),1:"CITY STATE UNKNOWN")
.S:$L(DGA(DGA)) DGA(DGA)=DGA(DGA)_" "_$P(VAPA(18),"^",2)
K I,VAPA Q
Q
AS S Y=$P(DGD,"^",1),Y=$P(Y,".",1) X ^DD("DD") S:$P(DGD,"^",11) DGSCOND=1 S DGD(1)=$S($P(DGD,"^",11):"*",1:" ")_Y,DGD(2)=$S($D(^DG(405.2,+$P(DGD,"^",18),0)):$P(^(0),"^",1),1:DGU)
S DGD(3)=$S($D(^DIC(42,+$P(DGD,"^",6),0)):$P(^(0),"^",1),1:DGU)
S DGD(4)=$S($P(DGD,"^",10)]"":$E($P(DGD,"^",10),1,30),1:"ADMITTING DIAGNOSIS UNSPECIFIED"),DGD(5)=$S($D(^DIC(43.4,+$P(DGADM(I,4),"^",1),0)):$P(^(0),"^",1),1:DGU) Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGOVBC1 4779 printed Dec 13, 2024@02:47:06 Page 2
DGOVBC1 ;ALB/MRL - VBC OUTPUT ; 12 FEB 87
+1 ;;5.3;Registration;**162,489**;Aug 13, 1993
+2 NEW VAPA
+3 KILL DGLN
SET $PIECE(DGLN," ",80)=""
SET DGU="UNKNOWN"
SET DGPP=""
+4 FOR DGPP1=0:0
SET DGPP=$ORDER(^UTILITY($JOB,"DGOVBC",DGPP))
if (DGPP="")!($GET(ZTSTOP)=1)
QUIT
SET DFN=^UTILITY($JOB,"DGOVBC",DGPP)
DO DIS
DO ENDREP^DGUTL
Q KILL DGCA,I,DGX,X,Y,%DT,DGFR,DGHD,DGHD1,DGHOW,DGIOM,DGLIN,DGLN,DGPP,DGPP1,DGTO,DGU,DGVAR,DIC,DFN,DGCT,DGDFN,DGP,DGPGM,ZTSTOP,^UTILITY($JOB,"DGOVBC")
DO CLOSE^DGUTQ
QUIT
+1 GOTO Q^DGOVBC2
DIS IF $$FIRST^DGUTL
QUIT
+1 DO NOW^%DTC
SET Y=$EXTRACT(%,1,12)
WRITE !,"VETERANS ASSISTANCE UNIT RECORD",?53,"PRINTED: ",$$FMTE^XLFDT(Y,1),?DGHD1,DGHD,!,DGLIN,!
KILL Y
+2 DO DEM^VADPT
DO L
WRITE !,"1. Patient Name: ",$SELECT(VADM(1)]"":VADM(1),1:"UNSPECIFIED PATIENT #"_DFN),?55,"| 2. DOB: ",$PIECE(VADM(3),"^",2)
+3 DO PID^VADPT6
WRITE ?80,"| 3. PT ID: ",$SELECT(VA("PID"):VA("PID"),1:DGU),?106,"| 4. Claim #: "
SET DGMS=$SELECT(VADM(10):$PIECE(VADM(10),"^",2),1:DGU)
KILL VA,VADM
DO ELIG^VADPT
WRITE $SELECT(VAEL(7):VAEL(7),1:DGU),!
SET DGSC=+VAEL(3)
SET DGMT=$PIECE(VAEL(9),"^",2)
KILL VAEL
+4 WRITE "_______________________________________________________|________________________|_________________________|_______________________"
+5 DO ADD^VADPT
DO A
WRITE !,"5. Address Information [Street, City, State, Zip Code]:"
FOR I=0:0
SET I=$ORDER(DGA(I))
if 'I
QUIT
if I>1
WRITE !
WRITE ?57,DGA(I),!
+6 IF VAPA(12)=1
Begin DoDot:1
+7 DO L
+8 DO AC
WRITE !,"5A. Confidential Address Information [Street, City, State, Zip Code]:"
FOR I=0:0
SET I=$ORDER(DGA(I))
if 'I
QUIT
if I>1
WRITE !
WRITE ?57,DGA(I)
End DoDot:1
+9 KILL DGA
WRITE !
DO SVC^VADPT
DO L
WRITE !,"6. Service Record",?35,"Service #",?55,"Entry Date",?75,"Separation Date",?108,"Discharge Type"
+10 WRITE $CHAR(13)," ","______________",$EXTRACT(DGLN,1,18),"_________",$EXTRACT(DGLN,1,11),"__________",$EXTRACT(DGLN,1,10),"_______________",$EXTRACT(DGLN,1,18),"______________"
SET DGPOW=VASV(4)
+11 FOR I=6:1:8
IF VASV(I)
WRITE !?3,$SELECT(VASV(I,1):$PIECE(VASV(I,1),"^",2),1:DGU),?35,$SELECT($LENGTH(VASV(I,2)):VASV(I,2),1:DGU),?55,$SELECT('VASV(I,4):DGU,1:$PIECE(VASV(I,4),"^",2)),?75,$SELECT('VASV(I,5):DGU,1:...
... $PIECE(VASV(I,5),"^",2)),?108,$SELECT(VASV(I,3):$PIECE(VASV(I,3),"^",2),1:DGU)
+12 KILL VASV
WRITE !
DO L
SET DGCT=0
FOR I=0:0
SET I=$ORDER(^DGPM("ATID1",DFN,I))
if 'I!(DGCT=2)
QUIT
FOR DGCA=0:0
SET DGCA=$ORDER(^DGPM("ATID1",DFN,I,DGCA))
if 'DGCA!(DGCT=2)
QUIT
IF $DATA(^DGPM(DGCA,0))
SET DGCT=DGCT+1
SET DGADM(DGCT)=^(0)
SET DGADM(DGCT,4)=$PIECE(^(0),"^",12)
+13 SET DGSCOND=0
WRITE !,"7. Admission Date"
IF 'DGCT
WRITE ": NO ADMISSIONS ON FILE FOR THIS APPLICANT."
GOTO ^DGOVBC2
+14 WRITE ?20,"Admission Type",?55,"Ward",?70,"Admitting Diagnosis",?105,"Admission Authority"
+15 WRITE $CHAR(13)," ","______________"," ","______________",$EXTRACT(DGLN,1,21),"____",$EXTRACT(DGLN,1,11),"___________________",$EXTRACT(DGLN,1,16),"___________________"
+16 FOR I=1:1:DGCT
SET DGD=DGADM(I)
SET DGD1=DGADM(I,4)
DO AS
WRITE !?3,DGD(1),?20,DGD(2),?55,$EXTRACT(DGD(3),1,10),?70,DGD(4),?105,$EXTRACT(DGD(5),1,25)
+17 DO H^DGUTL
SET DGT=DGTIME
KILL DGTIME
DO ^DGINPW
WRITE !?4,"NOTE: ",$SELECT('DG1:"NOT CURRENTLY AN INPATIENT.",1:$SELECT($DATA(^DIC(42,+DG1,0)):"CURRENTLY AN INPATIENT ON WARD '"_$PIECE(^(0),"^",1)_"'."),1:"INPATIENT ON UNKNOWN WARD.")
+18 IF DGSCOND
WRITE !?4,"NOTE: Asterisk [*] indicates admission for Service Connected Condition."
+19 KILL DGSCOND
GOTO ^DGOVBC2
L FOR DGL=1:1:$SELECT($DATA(IOM):(IOM-2),1:130)
WRITE "_"
+1 QUIT
PT FOR I=0,.11,.15,.3,.31,.32,.36,.361,.362,.52,"VET"
SET DGP(I)=$SELECT($DATA(^DPT(DFN,I)):^(I),1:"")
+1 SET DGSC=$SELECT($PIECE(DGP(.3),"^",1)="Y":1,1:0)
QUIT
A SET DGA=1
FOR I=1:1:3
if '$LENGTH(VAPA(I))
QUIT
if I=3
SET DGA(2)=DGA(2)_", "_VAPA(I)
if DGA<3
SET DGA(I)=VAPA(I)
SET DGA=DGA+1
+1 IF VAPA(1)']""
SET DGA(1)="STREET ADDRESS UNKNOWN"
SET DGA=2
+2 SET DGA(DGA)=$SELECT($LENGTH(VAPA(4))&(VAPA(5)):VAPA(4)_", "_$PIECE(VAPA(5),"^",2),$LENGTH(VAPA(4)):VAPA(4),VAPA(5):$PIECE(VAPA(5),"^",2),1:"CITY STATE UNKNOWN")
+3 if $LENGTH(DGA(DGA))
SET DGA(DGA)=DGA(DGA)_" "_VAPA(6)
+4 IF VAPA(12)=0
KILL I,J
+5 QUIT
AC ;Formatting Confidential Address Information
+1 KILL DGA
+2 IF VAPA(12)=1
Begin DoDot:1
+3 NEW DGASEQ,SEQ
+4 SET DGA=13
FOR I=13:1:15
if '$LENGTH(VAPA(I))
QUIT
if I=15
SET DGA(14)=DGA(14)_", "_VAPA(I)
if DGA<15
SET DGA(I)=VAPA(I)
SET DGA=DGA+1
+5 SET DGA(19)="______________________________________________"
+6 SET DGA(20)="Confidential Start Date: "_$PIECE(VAPA(20),"^",2)
+7 SET DGA(21)="Confidential End Date: "_$PIECE(VAPA(21),"^",2)
+8 SET DGA(22)="Confidential Address Categories:"
+9 SET SEQ=""
SET DGASEQ=23
FOR
SET SEQ=$ORDER(VAPA(22,SEQ))
if SEQ=""
QUIT
Begin DoDot:2
+10 IF $PIECE(VAPA(22,SEQ),"^",3)="Y"
SET DGA(DGASEQ)=$PIECE(VAPA(22,SEQ),"^",2)
SET DGASEQ=DGASEQ+1
End DoDot:2
+11 IF VAPA(13)']""
SET DGA(1)="STREET ADDRESS UNKNOWN"
SET DGA=2
+12 SET DGA(DGA)=$SELECT($LENGTH(VAPA(16))&(VAPA(17)):VAPA(16)_", "_$PIECE(VAPA(17),"^",2),$LENGTH(VAPA(16)):VAPA(16),VAPA(17):$PIECE(VAPA(17),"^",2),1:"CITY STATE UNKNOWN")
+13 if $LENGTH(DGA(DGA))
SET DGA(DGA)=DGA(DGA)_" "_$PIECE(VAPA(18),"^",2)
End DoDot:1
+14 KILL I,VAPA
QUIT
+15 QUIT
AS SET Y=$PIECE(DGD,"^",1)
SET Y=$PIECE(Y,".",1)
XECUTE ^DD("DD")
if $PIECE(DGD,"^",11)
SET DGSCOND=1
SET DGD(1)=$SELECT($PIECE(DGD,"^",11):"*",1:" ")_Y
SET DGD(2)=$SELECT($DATA(^DG(405.2,+$PIECE(DGD,"^",18),0)):$PIECE(^(0),"^",1),1:DGU)
+1 SET DGD(3)=$SELECT($DATA(^DIC(42,+$PIECE(DGD,"^",6),0)):$PIECE(^(0),"^",1),1:DGU)
+2 SET DGD(4)=$SELECT($PIECE(DGD,"^",10)]"":$EXTRACT($PIECE(DGD,"^",10),1,30),1:"ADMITTING DIAGNOSIS UNSPECIFIED")
SET DGD(5)=$SELECT($DATA(^DIC(43.4,+$PIECE(DGADM(I,4),"^",1),0)):$PIECE(^(0),"^",1),1:DGU)
QUIT
