Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: VADPT60

VADPT60.m

Go to the documentation of this file.
  1. VADPT60 ;ALB/MJK - Patient ID Utilities; 12 AUG 89 @1200
  1. ;;5.3;Registration;;Aug 13, 1993
  1. ;
  1. EN D DT^DICRW S X="VADPT60",DIK="^DOPT("""_X_""","
  1. G:$D(^DOPT(X,7)) A S ^DOPT(X,0)="Patient ID Utilities^1N^"
  1. F I=1:1 S Y=$T(@I) Q:Y="" S ^DOPT(X,I,0)=$P(Y,";",3,99)
  1. D IXALL^DIK
  1. A ;
  1. W !! S DIC="^DOPT(""VADPT60"",",DIC(0)="IQEAM" D ^DIC Q:Y<0 D @+Y G A
  1. ;
  1. 1 ;;ID Format Enter/Edit
  1. G 1^VADPT61
  1. ;
  1. 2 ;;Eligibility Code Enter/Edit
  1. G 2^VADPT61
  1. ;
  1. 3 ;;Specific ID Format Reset (All Patients)
  1. W ! S DIC="^DIC(8.2,",DIC(0)="AEMQZ" D ^DIC K DIC G Q3:+Y<1 S VAFMT=+Y
  1. S X=Y(0) D WARN^VADPT61
  1. 31 W !!,"Are you sure" S %=2 D YN^DICN
  1. I '% W !?5,"Answer 'YES' if you wish to reset id's for all patients with",!?5,"this format." G 31
  1. G 3:%'=1
  1. S VAOPT=3 D TASK^VADPT61 G Q3
  1. QUE3 ; -- determine which elig use format
  1. D BEG^VADPT61
  1. K VAELG F VAELG=0:0 S VAELG=$O(^DIC(8,"AF",VAFMT,VAELG)) Q:'VAELG S VAELG(VAELG)=""
  1. ; -- find pt's and reset
  1. 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
  1. D END^VADPT61
  1. Q3 K DFN,VAELG,VAFMT Q
  1. ;
  1. 4 ;;Primary Eligibility ID Reset (All Patients)
  1. W !!,"Are you sure" S %=2 D YN^DICN
  1. 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
  1. G Q4:%'=1
  1. 41 S VAOPT=4 D TASK^VADPT61 G Q4
  1. QUE4 K VALL D BEG^VADPT61,ALL,END^VADPT61
  1. Q4 Q
  1. ;
  1. 5 ;;Specific Eligibility ID Reset (All Patients)
  1. W ! S DIC="^DIC(8,",DIC(0)="AEMQZ" D ^DIC K DIC G Q5:+Y<1 S VAELG=+Y
  1. I '$D(^DIC(8.2,+$P(Y(0),U,10),0)) W !!?5,*7,"No id format specified for this eligibility." G Q5
  1. S X=^(0) D WARN^VADPT61
  1. 51 W !!,"Are you sure" S %=2 D YN^DICN
  1. I '% W !?5,"Answer 'YES' if you wish to reset id's for all patients with",!?5,"this ELIGIBILITY." G 51
  1. G 5:%'=1
  1. S VAOPT=5 D TASK^VADPT61 G Q5
  1. QUE5 D BEG^VADPT61
  1. F DFN=0:0 S DFN=$O(^DPT(DFN)) Q:'DFN I $D(^DPT(DFN,"E",VAELG,0)) D IX
  1. D END^VADPT61
  1. Q5 K VAELG,DFN Q
  1. ;
  1. 6 ;;Reset ALL ID's for a Patient
  1. W ! S DIC="^DPT(",DIC(0)="AEMQ" D ^DIC K DIC G Q6:+Y<1 S DFN=+Y
  1. 61 W !!,"Are you sure" S %=2 D YN^DICN
  1. 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
  1. G 6:%'=1
  1. PAT ; -- entry point if DFN is defined
  1. 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)
  1. Q6 K DFN,VAELG
  1. Q
  1. ;
  1. 7 ;;Reset ALL ID's for ALL Patients
  1. W !!,"Are you sure" S %=2 D YN^DICN
  1. I '% W !?5,"Answer 'YES' if you want to reset all the id's associated",!?5,"with ALL patients." G 7
  1. G Q7:%'=1
  1. S VAOPT=7 D TASK^VADPT61 G Q7
  1. QUE7 S VALL="" D BEG^VADPT61,ALL,END^VADPT61
  1. Q7 K VALL
  1. Q
  1. ;
  1. FILE ;
  1. S $P(^DPT(DFN,"E",0),U,2)="2.0361P"
  1. I $D(^DPT(DFN,"E",VAELG,0)) D IX G PATQ
  1. L +^DPT(DFN,"E",VAELG)
  1. S $P(^(0),"^",3,4)=VAELG_"^"_($P(^DPT(DFN,"E",0),"^",4)+1)
  1. S ^DPT(DFN,"E",VAELG,0)=VAELG
  1. L -^DPT(DFN,"E",VAELG)
  1. S DA(1)=DFN,DA=VAELG,DIK="^DPT("_DA(1)_",""E"",",DIK(1)=".01" D EN1^DIK
  1. K DA,DIK Q
  1. PATQ Q
  1. ;
  1. IX ;
  1. S DA(1)=DFN,DA=VAELG,DIK="^DPT("_DA(1)_",""E"",",DIK(1)=".01^3" D EN^DIK
  1. K DA,DIK Q
  1. ;
  1. ALL ; -- resets all id's for all pt's
  1. ; if VALL not defined then only primary reset
  1. 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
  1. K VAPRI,DFN,VAELG
  1. Q
  1. ;
  1. PRI ; -- set/reset pri elig id
  1. S VAPRI=0
  1. I $D(^DPT(DFN,.36)) S (VAPRI,VAELG)=+^(.36) I $D(^DIC(8,VAELG,0)) D FILE
  1. Q
  1. ;
  1. UPDT ; -- called by v5 clean-up
  1. W !,">>>PRIMARY ELIGIBILITY ID UPDATE..."
  1. D 41 Q