VADPT60 ;ALB/MJK - Patient ID Utilities; 12 AUG 89 @1200
;;5.3;Registration;;Aug 13, 1993
;
EN D DT^DICRW S X="VADPT60",DIK="^DOPT("""_X_""","
G:$D(^DOPT(X,7)) A S ^DOPT(X,0)="Patient ID Utilities^1N^"
F I=1:1 S Y=$T(@I) Q:Y="" S ^DOPT(X,I,0)=$P(Y,";",3,99)
D IXALL^DIK
A ;
W !! S DIC="^DOPT(""VADPT60"",",DIC(0)="IQEAM" D ^DIC Q:Y<0 D @+Y G A
;
1 ;;ID Format Enter/Edit
G 1^VADPT61
;
2 ;;Eligibility Code Enter/Edit
G 2^VADPT61
;
3 ;;Specific ID Format Reset (All Patients)
W ! S DIC="^DIC(8.2,",DIC(0)="AEMQZ" D ^DIC K DIC G Q3:+Y<1 S VAFMT=+Y
S X=Y(0) D WARN^VADPT61
31 W !!,"Are you sure" S %=2 D YN^DICN
I '% W !?5,"Answer 'YES' if you wish to reset id's for all patients with",!?5,"this format." G 31
G 3:%'=1
S VAOPT=3 D TASK^VADPT61 G Q3
QUE3 ; -- determine which elig use format
D BEG^VADPT61
K VAELG F VAELG=0:0 S VAELG=$O(^DIC(8,"AF",VAFMT,VAELG)) Q:'VAELG S VAELG(VAELG)=""
; -- find pt's and reset
F DFN=0:0 S DFN=$O(^DPT(DFN)) Q:'DFN F VAELG=0:0 S VAELG=$O(^DPT(DFN,"E",VAELG)) Q:'VAELG I $D(VAELG(VAELG)),$D(^(VAELG,0)) D IX
D END^VADPT61
Q3 K DFN,VAELG,VAFMT Q
;
4 ;;Primary Eligibility ID Reset (All Patients)
W !!,"Are you sure" S %=2 D YN^DICN
I '% W !?5,"Answer 'YES' if you wish to set or reset the patient id for",!?5,"the id format associated with EACH patient's primary eligibility." G 4
G Q4:%'=1
41 S VAOPT=4 D TASK^VADPT61 G Q4
QUE4 K VALL D BEG^VADPT61,ALL,END^VADPT61
Q4 Q
;
5 ;;Specific Eligibility ID Reset (All Patients)
W ! S DIC="^DIC(8,",DIC(0)="AEMQZ" D ^DIC K DIC G Q5:+Y<1 S VAELG=+Y
I '$D(^DIC(8.2,+$P(Y(0),U,10),0)) W !!?5,*7,"No id format specified for this eligibility." G Q5
S X=^(0) D WARN^VADPT61
51 W !!,"Are you sure" S %=2 D YN^DICN
I '% W !?5,"Answer 'YES' if you wish to reset id's for all patients with",!?5,"this ELIGIBILITY." G 51
G 5:%'=1
S VAOPT=5 D TASK^VADPT61 G Q5
QUE5 D BEG^VADPT61
F DFN=0:0 S DFN=$O(^DPT(DFN)) Q:'DFN I $D(^DPT(DFN,"E",VAELG,0)) D IX
D END^VADPT61
Q5 K VAELG,DFN Q
;
6 ;;Reset ALL ID's for a Patient
W ! S DIC="^DPT(",DIC(0)="AEMQ" D ^DIC K DIC G Q6:+Y<1 S DFN=+Y
61 W !!,"Are you sure" S %=2 D YN^DICN
I '% W !?5,"Answer 'YES' if you want to reset all the id's associated",!?5,"with this patient.",!!?5,"If the id format requires user input, you will be asked to enter the id." G 61
G 6:%'=1
PAT ; -- entry point if DFN is defined
F VAELG=0:0 S VAELG=$O(^DPT(DFN,"E",VAELG)) Q:'VAELG I $D(^(VAELG,0)),$D(^DIC(8,VAELG,0)) W:'$D(VABATCH) !?5,"...",$P(^(0),U) D IX I '$D(VABATCH) D ASK^VADPT61 W ?40,$P(^DPT(DFN,"E",VAELG,0),U,3)_" / "_$P(^(0),U,4)
Q6 K DFN,VAELG
Q
;
7 ;;Reset ALL ID's for ALL Patients
W !!,"Are you sure" S %=2 D YN^DICN
I '% W !?5,"Answer 'YES' if you want to reset all the id's associated",!?5,"with ALL patients." G 7
G Q7:%'=1
S VAOPT=7 D TASK^VADPT61 G Q7
QUE7 S VALL="" D BEG^VADPT61,ALL,END^VADPT61
Q7 K VALL
Q
;
FILE ;
S $P(^DPT(DFN,"E",0),U,2)="2.0361P"
I $D(^DPT(DFN,"E",VAELG,0)) D IX G PATQ
L +^DPT(DFN,"E",VAELG)
S $P(^(0),"^",3,4)=VAELG_"^"_($P(^DPT(DFN,"E",0),"^",4)+1)
S ^DPT(DFN,"E",VAELG,0)=VAELG
L -^DPT(DFN,"E",VAELG)
S DA(1)=DFN,DA=VAELG,DIK="^DPT("_DA(1)_",""E"",",DIK(1)=".01" D EN1^DIK
K DA,DIK Q
PATQ Q
;
IX ;
S DA(1)=DFN,DA=VAELG,DIK="^DPT("_DA(1)_",""E"",",DIK(1)=".01^3" D EN^DIK
K DA,DIK Q
;
ALL ; -- resets all id's for all pt's
; if VALL not defined then only primary reset
F DFN=0:0 S DFN=$O(^DPT(DFN)) Q:'DFN D PRI I $D(VALL) F VAELG=0:0 S VAELG=$O(^DPT(DFN,"E",VAELG)) Q:'VAELG D IX:VAELG'=VAPRI
K VAPRI,DFN,VAELG
Q
;
PRI ; -- set/reset pri elig id
S VAPRI=0
I $D(^DPT(DFN,.36)) S (VAPRI,VAELG)=+^(.36) I $D(^DIC(8,VAELG,0)) D FILE
Q
;
UPDT ; -- called by v5 clean-up
W !,">>>PRIMARY ELIGIBILITY ID UPDATE..."
D 41 Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVADPT60 3828 printed Apr 09, 2024@21:50:34 Page 2
VADPT60 ;ALB/MJK - Patient ID Utilities; 12 AUG 89 @1200
+1 ;;5.3;Registration;;Aug 13, 1993
+2 ;
EN DO DT^DICRW
SET X="VADPT60"
SET DIK="^DOPT("""_X_""","
+1 if $DATA(^DOPT(X,7))
GOTO A
SET ^DOPT(X,0)="Patient ID Utilities^1N^"
+2 FOR I=1:1
SET Y=$TEXT(@I)
if Y=""
QUIT
SET ^DOPT(X,I,0)=$PIECE(Y,";",3,99)
+3 DO IXALL^DIK
A ;
+1 WRITE !!
SET DIC="^DOPT(""VADPT60"","
SET DIC(0)="IQEAM"
DO ^DIC
if Y<0
QUIT
DO @+Y
GOTO A
+2 ;
1 ;;ID Format Enter/Edit
+1 GOTO 1^VADPT61
+2 ;
2 ;;Eligibility Code Enter/Edit
+1 GOTO 2^VADPT61
+2 ;
3 ;;Specific ID Format Reset (All Patients)
+1 WRITE !
SET DIC="^DIC(8.2,"
SET DIC(0)="AEMQZ"
DO ^DIC
KILL DIC
if +Y<1
GOTO Q3
SET VAFMT=+Y
+2 SET X=Y(0)
DO WARN^VADPT61
31 WRITE !!,"Are you sure"
SET %=2
DO YN^DICN
+1 IF '%
WRITE !?5,"Answer 'YES' if you wish to reset id's for all patients with",!?5,"this format."
GOTO 31
+2 if %'=1
GOTO 3
+3 SET VAOPT=3
DO TASK^VADPT61
GOTO Q3
QUE3 ; -- determine which elig use format
+1 DO BEG^VADPT61
+2 KILL VAELG
FOR VAELG=0:0
SET VAELG=$ORDER(^DIC(8,"AF",VAFMT,VAELG))
if 'VAELG
QUIT
SET VAELG(VAELG)=""
+3 ; -- find pt's and reset
+4 FOR DFN=0:0
SET DFN=$ORDER(^DPT(DFN))
if 'DFN
QUIT
FOR VAELG=0:0
SET VAELG=$ORDER(^DPT(DFN,"E",VAELG))
if 'VAELG
QUIT
IF $DATA(VAELG(VAELG))
IF $DATA(^(VAELG,0))
DO IX
+5 DO END^VADPT61
Q3 KILL DFN,VAELG,VAFMT
QUIT
+1 ;
4 ;;Primary Eligibility ID Reset (All Patients)
+1 WRITE !!,"Are you sure"
SET %=2
DO YN^DICN
+2 IF '%
WRITE !?5,"Answer 'YES' if you wish to set or reset the patient id for",!?5,"the id format associated with EACH patient's primary eligibility."
GOTO 4
+3 if %'=1
GOTO Q4
41 SET VAOPT=4
DO TASK^VADPT61
GOTO Q4
QUE4 KILL VALL
DO BEG^VADPT61
DO ALL
DO END^VADPT61
Q4 QUIT
+1 ;
5 ;;Specific Eligibility ID Reset (All Patients)
+1 WRITE !
SET DIC="^DIC(8,"
SET DIC(0)="AEMQZ"
DO ^DIC
KILL DIC
if +Y<1
GOTO Q5
SET VAELG=+Y
+2 IF '$DATA(^DIC(8.2,+$PIECE(Y(0),U,10),0))
WRITE !!?5,*7,"No id format specified for this eligibility."
GOTO Q5
+3 SET X=^(0)
DO WARN^VADPT61
51 WRITE !!,"Are you sure"
SET %=2
DO YN^DICN
+1 IF '%
WRITE !?5,"Answer 'YES' if you wish to reset id's for all patients with",!?5,"this ELIGIBILITY."
GOTO 51
+2 if %'=1
GOTO 5
+3 SET VAOPT=5
DO TASK^VADPT61
GOTO Q5
QUE5 DO BEG^VADPT61
+1 FOR DFN=0:0
SET DFN=$ORDER(^DPT(DFN))
if 'DFN
QUIT
IF $DATA(^DPT(DFN,"E",VAELG,0))
DO IX
+2 DO END^VADPT61
Q5 KILL VAELG,DFN
QUIT
+1 ;
6 ;;Reset ALL ID's for a Patient
+1 WRITE !
SET DIC="^DPT("
SET DIC(0)="AEMQ"
DO ^DIC
KILL DIC
if +Y<1
GOTO Q6
SET DFN=+Y
61 WRITE !!,"Are you sure"
SET %=2
DO YN^DICN
+1 IF '%
WRITE !?5,"Answer 'YES' if you want to reset all the id's associated",!?5,"with this patient.",!!?5,"If the id format requires user input, you will be asked to enter the id."
GOTO 61
+2 if %'=1
GOTO 6
PAT ; -- entry point if DFN is defined
+1 FOR VAELG=0:0
SET VAELG=$ORDER(^DPT(DFN,"E",VAELG))
if 'VAELG
QUIT
IF $DATA(^(VAELG,0))
IF $DATA(^DIC(8,VAELG,0))
if '$DATA(VABATCH)
WRITE !?5,"...",$PIECE(^(0),U)
DO IX
IF '$DATA(VABATCH)
DO ASK^VADPT61
WRITE ?40,$PIECE(^DPT(DFN,"E",VAELG,0),U,3)_" / "_$PIECE(^(0),U,4)
Q6 KILL DFN,VAELG
+1 QUIT
+2 ;
7 ;;Reset ALL ID's for ALL Patients
+1 WRITE !!,"Are you sure"
SET %=2
DO YN^DICN
+2 IF '%
WRITE !?5,"Answer 'YES' if you want to reset all the id's associated",!?5,"with ALL patients."
GOTO 7
+3 if %'=1
GOTO Q7
+4 SET VAOPT=7
DO TASK^VADPT61
GOTO Q7
QUE7 SET VALL=""
DO BEG^VADPT61
DO ALL
DO END^VADPT61
Q7 KILL VALL
+1 QUIT
+2 ;
FILE ;
+1 SET $PIECE(^DPT(DFN,"E",0),U,2)="2.0361P"
+2 IF $DATA(^DPT(DFN,"E",VAELG,0))
DO IX
GOTO PATQ
+3 LOCK +^DPT(DFN,"E",VAELG)
+4 SET $PIECE(^(0),"^",3,4)=VAELG_"^"_($PIECE(^DPT(DFN,"E",0),"^",4)+1)
+5 SET ^DPT(DFN,"E",VAELG,0)=VAELG
+6 LOCK -^DPT(DFN,"E",VAELG)
+7 SET DA(1)=DFN
SET DA=VAELG
SET DIK="^DPT("_DA(1)_",""E"","
SET DIK(1)=".01"
DO EN1^DIK
+8 KILL DA,DIK
QUIT
PATQ QUIT
+1 ;
IX ;
+1 SET DA(1)=DFN
SET DA=VAELG
SET DIK="^DPT("_DA(1)_",""E"","
SET DIK(1)=".01^3"
DO EN^DIK
+2 KILL DA,DIK
QUIT
+3 ;
ALL ; -- resets all id's for all pt's
+1 ; if VALL not defined then only primary reset
+2 FOR DFN=0:0
SET DFN=$ORDER(^DPT(DFN))
if 'DFN
QUIT
DO PRI
IF $DATA(VALL)
FOR VAELG=0:0
SET VAELG=$ORDER(^DPT(DFN,"E",VAELG))
if 'VAELG
QUIT
if VAELG'=VAPRI
DO IX
+3 KILL VAPRI,DFN,VAELG
+4 QUIT
+5 ;
PRI ; -- set/reset pri elig id
+1 SET VAPRI=0
+2 IF $DATA(^DPT(DFN,.36))
SET (VAPRI,VAELG)=+^(.36)
IF $DATA(^DIC(8,VAELG,0))
DO FILE
+3 QUIT
+4 ;
UPDT ; -- called by v5 clean-up
+1 WRITE !,">>>PRIMARY ELIGIBILITY ID UPDATE..."
+2 DO 41
QUIT
