source: FOIAVistA/trunk/r/DRUG_ACCOUNTABILITY-PSA/PSAV3P53.m@ 1310

PSAV3P53 ;VMP/PDW-POST INIT *53 FIND BAD 'C' INDEX, KILL OLD, SET PROPER  'C' & 'B' INDEXES; 8/20/05
 ;;3.0;DRUG ACCOUNTABILITY;**53**; 4/30/97
ST ;walk 'C' entries finding bad entries , pull values, kill old, set new indexes
 S PSASUB=3000101 ;1JAN2000
 ;
 W:$G(PSASHOW) !,"by DATES"
 F  S PSASUB=$O(^PSD(58.8,"C",PSASUB)) Q:PSASUB'>0  D
 . S PSALOC=$O(^PSD(58.8,"C",PSASUB,0))
 . S PSADRG=0 F  S PSADRG=$O(^PSD(58.8,"C",PSASUB,PSALOC,0)) Q:PSADRG'>0  D
 .. K ^PSD(58.8,"C",PSASUB,PSALOC,PSADRG) X "S X=$ZR" W:$G(PSASHOW) !,"K ",X
 .. K ^PSD(58.8,PSALOC,1,"B",PSASUB,PSADRG) X "S X=$ZR" W:$G(PSASHOW) !,"K ",X
 .. S ^PSD(58.8,"C",PSADRG,PSALOC,PSADRG)="" X "S X=$ZR" W:$G(PSASHOW) !,"S ",X
 .. S ^PSD(58.8,PSALOC,1,"B",PSADRG,PSADRG)="" X "S X=$ZR" W:$G(PSASHOW) !,"S ",X
 W:$G(PSASHOW) !,"by LOCATION"
 S PSALOC=0
 F  S PSALOC=$O(^PSD(58.8,PSALOC)) Q:PSALOC'>0  D
 . S PSADRG=0
 . F  S PSADRG=$O(^PSD(58.8,PSALOC,1,PSADRG)) Q:PSADRG'>0  D
 .. ;scrub B index
 .. S PSADRG2=0
 .. F  S PSADRG2=$O(^PSD(58.8,PSALOC,1,"B",PSADRG,PSADRG2)) Q:PSADRG2'>0  D
 ...I PSADRG2'=PSADRG K ^PSD(58.8,PSALOC,1,"B",PSADRG,PSADRG2) X "S X=$ZR" W:$G(PSASHOW) !,"K ",X
 .. ;check valid B index
 .. 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
 .. ;check valid C index
 .. 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
 W:$G(PSASHOW) !,"by C INDEX"
 S PSADRG=0 F  S PSADRG=$O(^PSD(58.8,"C",PSADRG)) Q:PSADRG'>0  D
 . S PSALOC=0 F  S PSALOC=$O(^PSD(58.8,"C",PSADRG,PSALOC)) Q:PSALOC'>0  D
 .. S PSADRG2=0 F  S PSADRG2=$O(^PSD(58.8,"C",PSADRG,PSALOC,PSADRG2)) Q:PSADRG2'>0  D
 ... I PSADRG2'=PSADRG K ^PSD(58.8,"C",PSADRG,PSALOC,PSADRG2) X "S X=$ZR" W:$G(PSASHOW) !,"K ",X
 K PSALOC,PSADRG,PSADRG2
 Q