source: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VADPT60.m@ 1800

Last change on this file since 1800 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.6 KB
RevLine 
[613]1VADPT60 ;ALB/MJK - Patient ID Utilities; 12 AUG 89 @1200
2 ;;5.3;Registration;;Aug 13, 1993
3 ;
4EN D DT^DICRW S X="VADPT60",DIK="^DOPT("""_X_""","
5 G:$D(^DOPT(X,7)) A S ^DOPT(X,0)="Patient ID Utilities^1N^"
6 F I=1:1 S Y=$T(@I) Q:Y="" S ^DOPT(X,I,0)=$P(Y,";",3,99)
7 D IXALL^DIK
8A ;
9 W !! S DIC="^DOPT(""VADPT60"",",DIC(0)="IQEAM" D ^DIC Q:Y<0 D @+Y G A
10 ;
111 ;;ID Format Enter/Edit
12 G 1^VADPT61
13 ;
142 ;;Eligibility Code Enter/Edit
15 G 2^VADPT61
16 ;
173 ;;Specific ID Format Reset (All Patients)
18 W ! S DIC="^DIC(8.2,",DIC(0)="AEMQZ" D ^DIC K DIC G Q3:+Y<1 S VAFMT=+Y
19 S X=Y(0) D WARN^VADPT61
2031 W !!,"Are you sure" S %=2 D YN^DICN
21 I '% W !?5,"Answer 'YES' if you wish to reset id's for all patients with",!?5,"this format." G 31
22 G 3:%'=1
23 S VAOPT=3 D TASK^VADPT61 G Q3
24QUE3 ; -- determine which elig use format
25 D BEG^VADPT61
26 K VAELG F VAELG=0:0 S VAELG=$O(^DIC(8,"AF",VAFMT,VAELG)) Q:'VAELG S VAELG(VAELG)=""
27 ; -- find pt's and reset
28 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
29 D END^VADPT61
30Q3 K DFN,VAELG,VAFMT Q
31 ;
324 ;;Primary Eligibility ID Reset (All Patients)
33 W !!,"Are you sure" S %=2 D YN^DICN
34 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
35 G Q4:%'=1
3641 S VAOPT=4 D TASK^VADPT61 G Q4
37QUE4 K VALL D BEG^VADPT61,ALL,END^VADPT61
38Q4 Q
39 ;
405 ;;Specific Eligibility ID Reset (All Patients)
41 W ! S DIC="^DIC(8,",DIC(0)="AEMQZ" D ^DIC K DIC G Q5:+Y<1 S VAELG=+Y
42 I '$D(^DIC(8.2,+$P(Y(0),U,10),0)) W !!?5,*7,"No id format specified for this eligibility." G Q5
43 S X=^(0) D WARN^VADPT61
4451 W !!,"Are you sure" S %=2 D YN^DICN
45 I '% W !?5,"Answer 'YES' if you wish to reset id's for all patients with",!?5,"this ELIGIBILITY." G 51
46 G 5:%'=1
47 S VAOPT=5 D TASK^VADPT61 G Q5
48QUE5 D BEG^VADPT61
49 F DFN=0:0 S DFN=$O(^DPT(DFN)) Q:'DFN I $D(^DPT(DFN,"E",VAELG,0)) D IX
50 D END^VADPT61
51Q5 K VAELG,DFN Q
52 ;
536 ;;Reset ALL ID's for a Patient
54 W ! S DIC="^DPT(",DIC(0)="AEMQ" D ^DIC K DIC G Q6:+Y<1 S DFN=+Y
5561 W !!,"Are you sure" S %=2 D YN^DICN
56 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
57 G 6:%'=1
58PAT ; -- entry point if DFN is defined
59 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)
60Q6 K DFN,VAELG
61 Q
62 ;
637 ;;Reset ALL ID's for ALL Patients
64 W !!,"Are you sure" S %=2 D YN^DICN
65 I '% W !?5,"Answer 'YES' if you want to reset all the id's associated",!?5,"with ALL patients." G 7
66 G Q7:%'=1
67 S VAOPT=7 D TASK^VADPT61 G Q7
68QUE7 S VALL="" D BEG^VADPT61,ALL,END^VADPT61
69Q7 K VALL
70 Q
71 ;
72FILE ;
73 S $P(^DPT(DFN,"E",0),U,2)="2.0361P"
74 I $D(^DPT(DFN,"E",VAELG,0)) D IX G PATQ
75 L +^DPT(DFN,"E",VAELG)
76 S $P(^(0),"^",3,4)=VAELG_"^"_($P(^DPT(DFN,"E",0),"^",4)+1)
77 S ^DPT(DFN,"E",VAELG,0)=VAELG
78 L -^DPT(DFN,"E",VAELG)
79 S DA(1)=DFN,DA=VAELG,DIK="^DPT("_DA(1)_",""E"",",DIK(1)=".01" D EN1^DIK
80 K DA,DIK Q
81PATQ Q
82 ;
83IX ;
84 S DA(1)=DFN,DA=VAELG,DIK="^DPT("_DA(1)_",""E"",",DIK(1)=".01^3" D EN^DIK
85 K DA,DIK Q
86 ;
87ALL ; -- resets all id's for all pt's
88 ; if VALL not defined then only primary reset
89 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
90 K VAPRI,DFN,VAELG
91 Q
92 ;
93PRI ; -- set/reset pri elig id
94 S VAPRI=0
95 I $D(^DPT(DFN,.36)) S (VAPRI,VAELG)=+^(.36) I $D(^DIC(8,VAELG,0)) D FILE
96 Q
97 ;
98UPDT ; -- called by v5 clean-up
99 W !,">>>PRIMARY ELIGIBILITY ID UPDATE..."
100 D 41 Q
Note: See TracBrowser for help on using the repository browser.