- 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
- 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
