- 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 Feb 19, 2025@00:27:23 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