- DGCOL ;ALB/MRL,ARF,RN - COLLATERAL PATIENT ENTRY-EDIT ; 04 MAY 87
- ;;5.3;Registration;**2,23,32,993,1023,1027,1052**;Aug 13, 1993;Build 7
- 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
- N DGEANS S DGEANS=$$WARNING
- I $G(DGEANS)'=1 G 1
- 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)
- D ENRRO ;DG*5.3*993 - Ask for SELF-SUPPORTED REGISTRATION ONLY REASON
- 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
- S DGADD=$S($D(^DPT(DFN,.11)):^(.11),1:""),DGADD=$P(DGAD1,"^",1,12)_"^^^^"_$$GET1^DIQ(2,DGCOLV,.121)_"^^"_$P(DGADD,"^",18),$P(DGADD,"^",7)=$$GET1^DIQ(2,DGCOLV,.117) D W !!,"Sponsor address data entered..." G Q
- .S DIE="^DPT(",DA=DFN,DR=".111///^S X=$P(DGADD,U);.112///^S X=$P(DGADD,U,2);.113///^S X=$P(DGADD,U,3);.114///^S X=$P(DGADD,U,4);.115///^S X=$P(DGADD,U,5);.116///^S X=$P(DGADD,U,6);.117///^S X=$P(DGADD,U,7)" D ^DIE
- .S DIE="^DPT(",DA=DFN,DR=".1171///^S X=$P(DGADD,U,8);.1172///^S X=$P(DGADD,U,9);.1173///^S X=$P(DGADD,U,10);.118///^S X=$P(DGADD,U,13);.119///^S X=$P(DGADD,U,14);.12///^S X=$P(DGADD,U,15);.121///^S X=$P(DGADD,U,16)" D ^DIE
- .S DIE="^DPT(",DA=DFN,DR=";.1118///^S X=$P(DGADD,U,18);.131///^S X=$P(DGPHON,U,2)" D ^DIE
- .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
- ENRRO ;DG*5.3*993 - Ask for SELF-SUPPORTED REGISTRATION ONLY REASON
- N DGENRODT,DGENRRSN,DGENSRCE,DGNOW,DIR,DGCURR,X,Y,DGKEY,DGREQNAME,DGENSTAT,DGWSHTOEN,DGRESP,DTOUT,DUOUT
- ;DG*5.3.1027 - Modifications to input logic of field .15 (REGISTRATION ONLY REASON) of the 27.11 (PATIENT ENROLLMENT) file
- ;W !!,"SELF-REPORTED REGISTRATION ONLY REASON" ;DG*5.3*1027 - not needed - replaced with code below
- W ! ;DG*5.3*1027 ;spacing only
- S DGENRRSN=""
- S DGCURR=$$FINDCUR^DGENA(DFN)
- ; DG*5.3*1027 If DO YOU WISH TO ENROLL field in PATIENT (#2) file is YES AND
- ; no current enrollment record AND
- ; The patient is unknown to ES, prompt for REGISTRATION ONLY REASON
- ; Supported DBIA #2701: The supported DBIA is used to access MPI
- ; APIs to retrieve ICN, determine if ICN
- ; is local and if site is LST.
- S DGKEY=$$GETICN^MPIF001(DFN)
- S DGREQNAME="VistAData"
- S DGRESP=0
- I $P(DGKEY,"^",1)'=-1 S DGRESP=$$EN^DGREGEEWS(DGKEY,DGREQNAME,.DGENSTAT,.DGWSHTOEN)
- I 'DGCURR,+DGRESP=0 F D Q:DGENRRSN
- . K DIR
- . S DIR("A")="SELF-REPORTED REGISTRATION ONLY REASON: "
- . S DIR(0)="27.11,.15,AO"
- . D ^DIR
- . I $D(DTOUT)!$D(DUOUT) S Y=""
- . S DGENRRSN=+Y
- . I 'DGENRRSN W !,"This is a required field.",! ;end DG*5.3*1027 changes
- I DGENRRSN S DGNOW=$$NOW^XLFDT(),DGENRODT=DGNOW,DGENSRCE=1 D REGONLY^DGEN(DFN)
- Q
- ;DG*5.3*993 End of mods
- 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
- WARNING() ;Add WARNING message to notify user of possible patient identity edits
- W !!,?25,"**WARNING!!**"
- W !!,"The edits you are about to make may potentially change the identity of"
- W !,"this patient. Please verify that you have selected the correct patient"
- W !,"and ensure that supporting documentation exists for these changes."
- N DIR,Y
- S DIR(0)="Y",DIR("A")="Do you wish to continue and save your edits"
- S DIR("B")="NO" D ^DIR
- Q Y
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGCOL 6176 printed Feb 19, 2025@00:07:42 Page 2
- DGCOL ;ALB/MRL,ARF,RN - COLLATERAL PATIENT ENTRY-EDIT ; 04 MAY 87
- +1 ;;5.3;Registration;**2,23,32,993,1023,1027,1052**;Aug 13, 1993;Build 7
- 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 NEW DGEANS
- SET DGEANS=$$WARNING
- +3 IF $GET(DGEANS)'=1
- GOTO 1
- +4 IF $DATA(DGRPOUT)
- KILL DGRPOUT
- GOTO 1
- +5 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
- +6 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,"--------------------"
- +7 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)
- +8 SET DGPHON=$SELECT($DATA(^DPT(DFN,.13)):$PIECE(^(.13),"^",1),1:"")
- SET $PIECE(DGPHON,"^",2)=$SELECT($DATA(^DPT(DGCOLV,.13)):$PIECE(^(.13),"^",1),1:"")
- +9 WRITE !!,"Phone: ",$SELECT($PIECE(DGPHON,"^",1)]"":$PIECE(DGPHON,"^",1),1:"UNKNOWN"),?45,"Phone: ",$SELECT($PIECE(DGPHON,"^",2)]"":$PIECE(DGPHON,"^",2),1:"UNKNOWN")
- +10 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)
- +11 ;DG*5.3*993 - Ask for SELF-SUPPORTED REGISTRATION ONLY REASON
- DO ENRRO
- 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 ;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
- +2 SET DGADD=$SELECT($DATA(^DPT(DFN,.11)):^(.11),1:"")
- SET DGADD=$PIECE(DGAD1,"^",1,12)_"^^^^"_$$GET1^DIQ(2,DGCOLV,.121)_"^^"_$PIECE(DGADD,"^",18)
- SET $PIECE(DGADD,"^",7)=$$GET1^DIQ(2,DGCOLV,.117)
- Begin DoDot:1
- +3 SET DIE="^DPT("
- SET DA=DFN
- SET DR=".111///^S X=$P(DGADD,U);.112///^S X=$P(DGADD,U,2);.113///^S X=$P(DGADD,U,3);.114///^S X=$P(DGADD,U,4);.115///^S X=$P(DGADD,U,5);.116///^S X=$P(DGADD,U,6);.117///^S X=$P(DGADD,U,7)"
- DO ^DIE
- +4 SET DIE="^DPT("
- SET DA=DFN
- SET DR=".1171///^S X=$P(DGADD,U,8);.1172///^S X=$P(DGADD,U,9);.1173///^S X=$P(DGADD,U,10);.118///^S X=$P(DGADD,U,13);.119///^S X=$P(DGADD,U,14);.12///^S X=$P(DGADD,U,15);.121///^S X=$P(DGADD,U,16)"
- DO ^DIE
- +5 SET DIE="^DPT("
- SET DA=DFN
- SET DR=";.1118///^S X=$P(DGADD,U,18);.131///^S X=$P(DGPHON,U,2)"
- DO ^DIE
- +6 QUIT
- End DoDot:1
- 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
- ENRRO ;DG*5.3*993 - Ask for SELF-SUPPORTED REGISTRATION ONLY REASON
- +1 NEW DGENRODT,DGENRRSN,DGENSRCE,DGNOW,DIR,DGCURR,X,Y,DGKEY,DGREQNAME,DGENSTAT,DGWSHTOEN,DGRESP,DTOUT,DUOUT
- +2 ;DG*5.3.1027 - Modifications to input logic of field .15 (REGISTRATION ONLY REASON) of the 27.11 (PATIENT ENROLLMENT) file
- +3 ;W !!,"SELF-REPORTED REGISTRATION ONLY REASON" ;DG*5.3*1027 - not needed - replaced with code below
- +4 ;DG*5.3*1027 ;spacing only
- WRITE !
- +5 SET DGENRRSN=""
- +6 SET DGCURR=$$FINDCUR^DGENA(DFN)
- +7 ; DG*5.3*1027 If DO YOU WISH TO ENROLL field in PATIENT (#2) file is YES AND
- +8 ; no current enrollment record AND
- +9 ; The patient is unknown to ES, prompt for REGISTRATION ONLY REASON
- +10 ; Supported DBIA #2701: The supported DBIA is used to access MPI
- +11 ; APIs to retrieve ICN, determine if ICN
- +12 ; is local and if site is LST.
- +13 SET DGKEY=$$GETICN^MPIF001(DFN)
- +14 SET DGREQNAME="VistAData"
- +15 SET DGRESP=0
- +16 IF $PIECE(DGKEY,"^",1)'=-1
- SET DGRESP=$$EN^DGREGEEWS(DGKEY,DGREQNAME,.DGENSTAT,.DGWSHTOEN)
- +17 IF 'DGCURR
- IF +DGRESP=0
- FOR
- Begin DoDot:1
- +18 KILL DIR
- +19 SET DIR("A")="SELF-REPORTED REGISTRATION ONLY REASON: "
- +20 SET DIR(0)="27.11,.15,AO"
- +21 DO ^DIR
- +22 IF $DATA(DTOUT)!$DATA(DUOUT)
- SET Y=""
- +23 SET DGENRRSN=+Y
- +24 ;end DG*5.3*1027 changes
- IF 'DGENRRSN
- WRITE !,"This is a required field.",!
- End DoDot:1
- if DGENRRSN
- QUIT
- +25 IF DGENRRSN
- SET DGNOW=$$NOW^XLFDT()
- SET DGENRODT=DGNOW
- SET DGENSRCE=1
- DO REGONLY^DGEN(DFN)
- +26 QUIT
- +27 ;DG*5.3*993 End of mods
- 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
- WARNING() ;Add WARNING message to notify user of possible patient identity edits
- +1 WRITE !!,?25,"**WARNING!!**"
- +2 WRITE !!,"The edits you are about to make may potentially change the identity of"
- +3 WRITE !,"this patient. Please verify that you have selected the correct patient"
- +4 WRITE !,"and ensure that supporting documentation exists for these changes."
- +5 NEW DIR,Y
- +6 SET DIR(0)="Y"
- SET DIR("A")="Do you wish to continue and save your edits"
- +7 SET DIR("B")="NO"
- DO ^DIR
- +8 QUIT Y
