DGCOL ;ALB/MRL - COLLATERAL PATIENT ENTRY-EDIT ; 04 MAY 87
;;5.3;Registration;**2,23,32,1015**;Aug 13, 1993;Build 21
1 K DFN W !! S DGDIR=$S($D(DGDIR):DGDIR,1:1),DIC="^DPT(",DIC(0)="AEQML",DIC("DR")=".03;.09;.02;.3601;1901///^S X=""N"";391///^S X=""COLLATERAL"";.361///^S X=""COLLATERAL OF VET."";.323///^S X=""OTHER NON-VETERANS"";"
S DLAYGO=2 D ^DIC I Y'>0 S DGDIR=0 K DLAYGO G Q
S DFN=+Y,DGVET=$S('$D(^DPT(DFN,"VET")):0,^("VET")="Y":1,1:0) I '$P(Y,"^",3),DGVET,'DGDIR G Q
EN S DGDIR=$S($D(DGDIR):DGDIR,1:0) G Q:'$D(DFN),VET:DGVET
S DGELG=$S('$D(^DPT(DFN,.36)):1,'$D(^DIC(8,+^(.36),0)):1,$P(^(0),"^",9)'=13:0,1:1),DGPS=$S('$D(^DPT(DFN,.32)):1,'$D(^DIC(21,+$P(^(.32),"^",3),0)):1,$P(^(0),"^",1)'["OTHER NON-VET":0,1:1) G:('DGELG!'DGPS) ECPS K DGELG,DGPS D EN^DGRPD
I $D(DGRPOUT) K DGRPOUT G 1
S (Y,DA)=DFN,DR="[DGCOLLATERAL]",DGNOCOL=0,DIE="^DPT(" D ^DIE G Q:DGNOCOL!'$D(^DPT(DFN,0)) I '$D(DGCOLV) W !!,"COLLATERAL VETERAN SPONSOR NAME IS UNSPECIFIED!!",*7 G EN
S DGAD=$S($D(^DPT(DFN,.11)):$P(^(.11),"^",1,12),1:""),DGAD1=$S($D(^DPT(+DGCOLV,.11)):$P(^(.11),"^",1,12),1:""),C=0 W !!,"APPLICANT ADDRESS DATA",?45,"SPONSOR ADDRESS DATA",!,"----------------------",?45,"--------------------"
S C=0,P=1,X=DGAD D AD S C=0,P=2,X=DGAD1 D AD F I=0:0 S I=$O(AD(I)) Q:'I W !,$P(AD(I),"^",1),?45,$P(AD(I),"^",2)
S DGPHON=$S($D(^DPT(DFN,.13)):$P(^(.13),"^",1),1:""),$P(DGPHON,"^",2)=$S($D(^DPT(DGCOLV,.13)):$P(^(.13),"^",1),1:"")
W !!,"Phone: ",$S($P(DGPHON,"^",1)]"":$P(DGPHON,"^",1),1:"UNKNOWN"),?45,"Phone: ",$S($P(DGPHON,"^",2)]"":$P(DGPHON,"^",2),1:"UNKNOWN")
W !!,"SPONSOR: ",$P(^DPT(DGCOLV,0),"^",1),", ",$E($P(^(0),"^",9),1,3),"-",$E($P(^(0),"^",9),4,5),"-",$E($P(^(0),"^",9),6,10)
ASK W !!,"DO YOU WISH TO EDIT COLLATERAL INFORMATION" S %=2 D YN^DICN G Q:%=2!(%=-1) I %=0 W !,"ENTER 'Y'ES OR 'N'O" G ASK
H W !!,"SHOULD COLLATERAL PATIENT ADDRESS DATA BE SAME AS SPONSOR'S" S %=2 D YN^DICN I %>0 S DGADED=(%-1) G ED
G Q:%=-1 W !!,"Y - To stuff in sponsor's address data.",!,"N - To edit collateral address data",!,"^ - To QUIT." G H
ED I DGADED S DR=".3601;.111;S:X']"""" Y=.114;.112;S:X']"""" Y=.114;.113:.115;.1112;.117;.131;",DIE="^DPT(",(DA,Y)=DFN D ^DIE G Q
S DGADD=$S($D(^DPT(DFN,.11)):^(.11),1:""),DGADD=$P(DGAD1,"^",1,12)_"^"_$P(DGADD,"^",13,999),^DPT(DFN,.11)=DGADD,$P(^DPT(DFN,.13),"^",1)=$P(DGPHON,"^",2) W !!,"Sponsor address data entered..." G Q
AD F I=1:1:5,12,7 I $P(X,"^",I)]"" D
.S D=$P(X,"^",I),C=C+1
.S:(I=12)&($L(D)>5) D=$E(D,1,5)_"-"_$E(D,6,20)
.S $P(AD(C),"^",P)=D S:I=5 $P(AD(C),"^",P)=$S($D(^DIC(5,+D,0)):$P(^(0),"^",1),1:"STATE UNKNOWN") I I=7 S $P(AD(C),"^",P)=$S($D(^DIC(5,+$P(X,"^",5),1,+D,0)):$P(^(0),"^",1),1:"UNKNOWN")
Q
VET W !!,*7,"Patient is a veteran and therefore should not be classified utilizing this",!,"option. If this veteran has Other Entitled Eligibilities please insure that "
W !,"the appropriate APPOINTMENT TYPE is selected at the time you make the",!,"appointment." G Q
ECPS K DGELG,DGPS W !!,*7,"Patient already has an eligibility code or period of service on file and",!,"therefore should not be classified using this option. If this veteran",!,"has Other Entitled Eligibilities, please insure that the"
W " appropriate",!,"APPOINTMENT TYPE is selected at the time you make the appointment."
Q K %,Y,DGVET,DIE,DIC,DGCOLV,DR,X,I,DGNOCOL,DA,AD,C,P,D,DGADD,I1,DGAD,DGAD1,DGADED,DGPHON G:DGDIR 1 K DGDIR S:$D(DFN) Y=DFN Q
DGCOL ;ALB/MRL - COLLATERAL PATIENT ENTRY-EDIT ; 04 MAY 87
+1 ;;5.3;Registration;**2,23,32,1015**;Aug 13, 1993;Build 21
1 KILL DFN
WRITE !!
SET DGDIR=$SELECT($DATA(DGDIR):DGDIR,1:1)
SET DIC="^DPT("
SET DIC(0)="AEQML"
SET DIC("DR")=".03;.09;.02;.3601;1901///^S X=""N"";391///^S X=""COLLATERAL"";.361///^S X=""COLLATERAL OF VET."";.323///^S X=""OTHER NON-VETERANS"";"
+1 SET DLAYGO=2
DO ^DIC
IF Y'>0
SET DGDIR=0
KILL DLAYGO
GOTO Q
+2 SET DFN=+Y
SET DGVET=$SELECT('$DATA(^DPT(DFN,"VET")):0,^("VET")="Y":1,1:0)
IF '$PIECE(Y,"^",3)
IF DGVET
IF 'DGDIR
GOTO Q
EN SET DGDIR=$SELECT($DATA(DGDIR):DGDIR,1:0)
IF '$DATA(DFN)
GOTO Q
IF DGVET
GOTO VET
+1 SET DGELG=$SELECT('$DATA(^DPT(DFN,.36)):1,'$DATA(^DIC(8,+^(.36),0)):1,$PIECE(^(0),"^",9)'=13:0,1:1)
SET DGPS=$SELECT('$DATA(^DPT(DFN,.32)):1,'$DATA(^DIC(21,+$PIECE(^(.32),"^",3),0)):1,$PIECE(^(0),"^",1)'["OTHER NON-VET":0,1:1)
IF ('DGELG!'DGPS)
GOTO ECPS
KILL DGELG,DGPS
DO EN^DGRPD
+2 IF $DATA(DGRPOUT)
KILL DGRPOUT
GOTO 1
+3 SET (Y,DA)=DFN
SET DR="[DGCOLLATERAL]"
SET DGNOCOL=0
SET DIE="^DPT("
DO ^DIE
IF DGNOCOL!'$DATA(^DPT(DFN,0))
GOTO Q
IF '$DATA(DGCOLV)
WRITE !!,"COLLATERAL VETERAN SPONSOR NAME IS UNSPECIFIED!!",*7
GOTO EN
+4 SET DGAD=$SELECT($DATA(^DPT(DFN,.11)):$PIECE(^(.11),"^",1,12),1:"")
SET DGAD1=$SELECT($DATA(^DPT(+DGCOLV,.11)):$PIECE(^(.11),"^",1,12),1:"")
SET C=0
WRITE !!,"APPLICANT ADDRESS DATA",?45,"SPONSOR ADDRESS DATA",!,"----------------------",?45,"--------------------"
+5 SET C=0
SET P=1
SET X=DGAD
DO AD
SET C=0
SET P=2
SET X=DGAD1
DO AD
FOR I=0:0
SET I=$ORDER(AD(I))
IF 'I
QUIT
WRITE !,$PIECE(AD(I),"^",1),?45,$PIECE(AD(I),"^",2)
+6 SET DGPHON=$SELECT($DATA(^DPT(DFN,.13)):$PIECE(^(.13),"^",1),1:"")
SET $PIECE(DGPHON,"^",2)=$SELECT($DATA(^DPT(DGCOLV,.13)):$PIECE(^(.13),"^",1),1:"")
+7 WRITE !!,"Phone: ",$SELECT($PIECE(DGPHON,"^",1)]"":$PIECE(DGPHON,"^",1),1:"UNKNOWN"),?45,"Phone: ",$SELECT($PIECE(DGPHON,"^",2)]"":$PIECE(DGPHON,"^",2),1:"UNKNOWN")
+8 WRITE !!,"SPONSOR: ",$PIECE(^DPT(DGCOLV,0),"^",1),", ",$EXTRACT($PIECE(^(0),"^",9),1,3),"-",$EXTRACT($PIECE(^(0),"^",9),4,5),"-",$EXTRACT($PIECE(^(0),"^",9),6,10)
ASK WRITE !!,"DO YOU WISH TO EDIT COLLATERAL INFORMATION"
SET %=2
DO YN^DICN
IF %=2!(%=-1)
GOTO Q
IF %=0
WRITE !,"ENTER 'Y'ES OR 'N'O"
GOTO ASK
H WRITE !!,"SHOULD COLLATERAL PATIENT ADDRESS DATA BE SAME AS SPONSOR'S"
SET %=2
DO YN^DICN
IF %>0
SET DGADED=(%-1)
GOTO ED
+1 IF %=-1
GOTO Q
WRITE !!,"Y - To stuff in sponsor's address data.",!,"N - To edit collateral address data",!,"^ - To QUIT."
GOTO H
ED IF DGADED
SET DR=".3601;.111;S:X']"""" Y=.114;.112;S:X']"""" Y=.114;.113:.115;.1112;.117;.131;"
SET DIE="^DPT("
SET (DA,Y)=DFN
DO ^DIE
GOTO Q
+1 SET DGADD=$SELECT($DATA(^DPT(DFN,.11)):^(.11),1:"")
SET DGADD=$PIECE(DGAD1,"^",1,12)_"^"_$PIECE(DGADD,"^",13,999)
SET ^DPT(DFN,.11)=DGADD
SET $PIECE(^DPT(DFN,.13),"^",1)=$PIECE(DGPHON,"^",2)
WRITE !!,"Sponsor address data entered..."
GOTO Q
AD FOR I=1:1:5,12,7
IF $PIECE(X,"^",I)]""
Begin DoDot:1
+1 SET D=$PIECE(X,"^",I)
SET C=C+1
+2 IF (I=12)&($LENGTH(D)>5)
SET D=$EXTRACT(D,1,5)_"-"_$EXTRACT(D,6,20)
+3 SET $PIECE(AD(C),"^",P)=D
IF I=5
SET $PIECE(AD(C),"^",P)=$SELECT($DATA(^DIC(5,+D,0)):$PIECE(^(0),"^",1),1:"STATE UNKNOWN")
IF I=7
SET $PIECE(AD(C),"^",P)=$SELECT($DATA(^DIC(5,+$PIECE(X,"^",5),1,+D,0)):$PIECE(^(0),"^",1),1:"UNKNOWN")
End DoDot:1
+4 QUIT
VET WRITE !!,*7,"Patient is a veteran and therefore should not be classified utilizing this",!,"option. If this veteran has Other Entitled Eligibilities please insure that "
+1 WRITE !,"the appropriate APPOINTMENT TYPE is selected at the time you make the",!,"appointment."
GOTO Q
ECPS KILL DGELG,DGPS
WRITE !!,*7,"Patient already has an eligibility code or period of service on file and",!,"therefore should not be classified using this option. If this veteran",!,"has Other Entitled Eligibilities, please insure that the"
+1 WRITE " appropriate",!,"APPOINTMENT TYPE is selected at the time you make the appointment."
Q KILL %,Y,DGVET,DIE,DIC,DGCOLV,DR,X,I,DGNOCOL,DA,AD,C,P,D,DGADD,I1,DGAD,DGAD1,DGADED,DGPHON
IF DGDIR
GOTO 1
KILL DGDIR
IF $DATA(DFN)
SET Y=DFN
QUIT
