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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSAV3P53 1863 printed Dec 13, 2024@01:51 Page 2
PSAV3P53 ;VMP/PDW-POST INIT *53 FIND BAD 'C' INDEX, KILL OLD, SET PROPER 'C' & 'B' INDEXES; 8/20/05
+1 ;;3.0;DRUG ACCOUNTABILITY;**53**; 4/30/97
ST ;walk 'C' entries finding bad entries , pull values, kill old, set new indexes
+1 ;1JAN2000
SET PSASUB=3000101
+2 ;
+3 if $GET(PSASHOW)
WRITE !,"by DATES"
+4 FOR
SET PSASUB=$ORDER(^PSD(58.8,"C",PSASUB))
if PSASUB'>0
QUIT
Begin DoDot:1
+5 SET PSALOC=$ORDER(^PSD(58.8,"C",PSASUB,0))
+6 SET PSADRG=0
FOR
SET PSADRG=$ORDER(^PSD(58.8,"C",PSASUB,PSALOC,0))
if PSADRG'>0
QUIT
Begin DoDot:2
+7 KILL ^PSD(58.8,"C",PSASUB,PSALOC,PSADRG)
XECUTE "S X=$ZR"
if $GET(PSASHOW)
WRITE !,"K ",X
+8 KILL ^PSD(58.8,PSALOC,1,"B",PSASUB,PSADRG)
XECUTE "S X=$ZR"
if $GET(PSASHOW)
WRITE !,"K ",X
+9 SET ^PSD(58.8,"C",PSADRG,PSALOC,PSADRG)=""
XECUTE "S X=$ZR"
if $GET(PSASHOW)
WRITE !,"S ",X
+10 SET ^PSD(58.8,PSALOC,1,"B",PSADRG,PSADRG)=""
XECUTE "S X=$ZR"
if $GET(PSASHOW)
WRITE !,"S ",X
End DoDot:2
End DoDot:1
+11 if $GET(PSASHOW)
WRITE !,"by LOCATION"
+12 SET PSALOC=0
+13 FOR
SET PSALOC=$ORDER(^PSD(58.8,PSALOC))
if PSALOC'>0
QUIT
Begin DoDot:1
+14 SET PSADRG=0
+15 FOR
SET PSADRG=$ORDER(^PSD(58.8,PSALOC,1,PSADRG))
if PSADRG'>0
QUIT
Begin DoDot:2
+16 ;scrub B index
+17 SET PSADRG2=0
+18 FOR
SET PSADRG2=$ORDER(^PSD(58.8,PSALOC,1,"B",PSADRG,PSADRG2))
if PSADRG2'>0
QUIT
Begin DoDot:3
+19 IF PSADRG2'=PSADRG
KILL ^PSD(58.8,PSALOC,1,"B",PSADRG,PSADRG2)
XECUTE "S X=$ZR"
if $GET(PSASHOW)
WRITE !,"K ",X
End DoDot:3
+20 ;check valid B index
+21 IF '$DATA(^PSD(58.8,PSALOC,1,"B",PSADRG,PSADRG))
SET ^PSD(58.8,PSALOC,1,"B",PSADRG,PSADRG)=""
XECUTE "S X=$ZR"
if $GET(PSASHOW)
WRITE !,"S ",X
+22 ;check valid C index
+23 IF '$DATA(^PSD(58.8,"C",PSADRG,PSALOC,PSADRG))
SET ^PSD(58.8,"C",PSADRG,PSALOC,PSADRG)=""
XECUTE "S X=$ZR"
if $GET(PSASHOW)
WRITE !,"S ",X
End DoDot:2
End DoDot:1
+24 if $GET(PSASHOW)
WRITE !,"by C INDEX"
+25 SET PSADRG=0
FOR
SET PSADRG=$ORDER(^PSD(58.8,"C",PSADRG))
if PSADRG'>0
QUIT
Begin DoDot:1
+26 SET PSALOC=0
FOR
SET PSALOC=$ORDER(^PSD(58.8,"C",PSADRG,PSALOC))
if PSALOC'>0
QUIT
Begin DoDot:2
+27 SET PSADRG2=0
FOR
SET PSADRG2=$ORDER(^PSD(58.8,"C",PSADRG,PSALOC,PSADRG2))
if PSADRG2'>0
QUIT
Begin DoDot:3
+28 IF PSADRG2'=PSADRG
KILL ^PSD(58.8,"C",PSADRG,PSALOC,PSADRG2)
XECUTE "S X=$ZR"
if $GET(PSASHOW)
WRITE !,"K ",X
End DoDot:3
End DoDot:2
End DoDot:1
+29 KILL PSALOC,PSADRG,PSADRG2
+30 QUIT
