source: WorldVistAEHR/trunk/r/DRUG_ACCOUNTABILITY-PSA/PSAV3P53.m@ 701

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

initial load of WorldVistAEHR

File size: 1.8 KB
Line 
1PSAV3P53 ;VMP/PDW-POST INIT *53 FIND BAD 'C' INDEX, KILL OLD, SET PROPER 'C' & 'B' INDEXES; 8/20/05
2 ;;3.0;DRUG ACCOUNTABILITY;**53**; 4/30/97
3ST ;walk 'C' entries finding bad entries , pull values, kill old, set new indexes
4 S PSASUB=3000101 ;1JAN2000
5 ;
6 W:$G(PSASHOW) !,"by DATES"
7 F S PSASUB=$O(^PSD(58.8,"C",PSASUB)) Q:PSASUB'>0 D
8 . S PSALOC=$O(^PSD(58.8,"C",PSASUB,0))
9 . S PSADRG=0 F S PSADRG=$O(^PSD(58.8,"C",PSASUB,PSALOC,0)) Q:PSADRG'>0 D
10 .. K ^PSD(58.8,"C",PSASUB,PSALOC,PSADRG) X "S X=$ZR" W:$G(PSASHOW) !,"K ",X
11 .. K ^PSD(58.8,PSALOC,1,"B",PSASUB,PSADRG) X "S X=$ZR" W:$G(PSASHOW) !,"K ",X
12 .. S ^PSD(58.8,"C",PSADRG,PSALOC,PSADRG)="" X "S X=$ZR" W:$G(PSASHOW) !,"S ",X
13 .. S ^PSD(58.8,PSALOC,1,"B",PSADRG,PSADRG)="" X "S X=$ZR" W:$G(PSASHOW) !,"S ",X
14 W:$G(PSASHOW) !,"by LOCATION"
15 S PSALOC=0
16 F S PSALOC=$O(^PSD(58.8,PSALOC)) Q:PSALOC'>0 D
17 . S PSADRG=0
18 . F S PSADRG=$O(^PSD(58.8,PSALOC,1,PSADRG)) Q:PSADRG'>0 D
19 .. ;scrub B index
20 .. S PSADRG2=0
21 .. F S PSADRG2=$O(^PSD(58.8,PSALOC,1,"B",PSADRG,PSADRG2)) Q:PSADRG2'>0 D
22 ...I PSADRG2'=PSADRG K ^PSD(58.8,PSALOC,1,"B",PSADRG,PSADRG2) X "S X=$ZR" W:$G(PSASHOW) !,"K ",X
23 .. ;check valid B index
24 .. I '$D(^PSD(58.8,PSALOC,1,"B",PSADRG,PSADRG)) S ^PSD(58.8,PSALOC,1,"B",PSADRG,PSADRG)="" X "S X=$ZR" W:$G(PSASHOW) !,"S ",X
25 .. ;check valid C index
26 .. I '$D(^PSD(58.8,"C",PSADRG,PSALOC,PSADRG)) S ^PSD(58.8,"C",PSADRG,PSALOC,PSADRG)="" X "S X=$ZR" W:$G(PSASHOW) !,"S ",X
27 W:$G(PSASHOW) !,"by C INDEX"
28 S PSADRG=0 F S PSADRG=$O(^PSD(58.8,"C",PSADRG)) Q:PSADRG'>0 D
29 . S PSALOC=0 F S PSALOC=$O(^PSD(58.8,"C",PSADRG,PSALOC)) Q:PSALOC'>0 D
30 .. S PSADRG2=0 F S PSADRG2=$O(^PSD(58.8,"C",PSADRG,PSALOC,PSADRG2)) Q:PSADRG2'>0 D
31 ... I PSADRG2'=PSADRG K ^PSD(58.8,"C",PSADRG,PSALOC,PSADRG2) X "S X=$ZR" W:$G(PSASHOW) !,"K ",X
32 K PSALOC,PSADRG,PSADRG2
33 Q
Note: See TracBrowser for help on using the repository browser.