PRCP5PRE ;WISC/RFJ-pre init for inventory version 5 ;29 Jun 94
;;5.0;IFCAP;;4/21/95
;
;
START ; start pre init to delete all PRCP options (except PRCPZ)
N %,DA,DIK,DIU,MENUDA,MENUDA1,PRCPDA,PRCPOPT,X
K X S X(1)="This pre-init to the Generic Inventory Package will delete all PRCP options (except PRCPZ) from the OPTION file. It will also clean up all menu pointers which reference the deleted PRCP options."
S X(2)="The pre-init to the Generic Inventory Package will also delete all PRCP input templates, sort templates, and print templates except the PRCPZ namespaced entries." D DISPLAY^PRCPUX2(1,78,.X)
;
W ! S PRCPOPT="PRCP" F S PRCPOPT=$O(^DIC(19,"B",PRCPOPT)) Q:$E(PRCPOPT,1,4)'="PRCP"!($E(PRCPOPT,1,5)="PRCPZ") S PRCPDA=0 F S PRCPDA=$O(^DIC(19,"B",PRCPOPT,PRCPDA)) Q:'PRCPDA D
. I PRCPOPT="PRCP MAIN MENU"!(PRCPOPT="PRCP2 MAIN MENU")!(PRCPOPT="PRCPW MAIN MENU")!(PRCPOPT="PRCP ALL") Q
. ; do not delete queued taskman options
. I PRCPOPT="PRCP OPEN BALANCES TASKMAN SET"!(PRCPOPT="PRCP PURGE AUTOMATIC RUN") Q
. W !," deleting option: ",PRCPOPT
. ; clean up menus first
. S MENUDA=0 F S MENUDA=$O(^DIC(19,"AD",PRCPDA,MENUDA)) Q:'MENUDA S MENUDA1=0 F S MENUDA1=$O(^DIC(19,"AD",PRCPDA,MENUDA,MENUDA1)) Q:'MENUDA1 D
. . N DA,DIK S DIK="^DIC(19,"_MENUDA_",10,",DA(1)=MENUDA,DA=MENUDA1 D ^DIK Q
. ; remove option
. S DIK="^DIC(19,",DA=PRCPDA D ^DIK W " deleted!"
;
; delete input, sort, and print templates
W !!,"deleting INPUT TEMPLATES:" S PRCPOPT="PRCP" F S PRCPOPT=$O(^DIE("B",PRCPOPT)) Q:$E(PRCPOPT,1,4)'="PRCP"!($E(PRCPOPT,1,5)="PRCPZ") S PRCPDA=0 F S PRCPDA=$O(^DIE("B",PRCPOPT,PRCPDA)) Q:'PRCPDA D
. W !?9,PRCPOPT S DIK="^DIE(",DA=PRCPDA D ^DIK W " deleted!"
W !!,"deleting SORT TEMPLATES:" S PRCPOPT="PRCP" F S PRCPOPT=$O(^DIBT("B",PRCPOPT)) Q:$E(PRCPOPT,1,4)'="PRCP"!($E(PRCPOPT,1,5)="PRCPZ") S PRCPDA=0 F S PRCPDA=$O(^DIBT("B",PRCPOPT,PRCPDA)) Q:'PRCPDA D
. W !?9,PRCPOPT S DIK="^DIBT(",DA=PRCPDA D ^DIK W " deleted!"
W !!,"deleting PRINT TEMPLATES:" S PRCPOPT="PRCP" F S PRCPOPT=$O(^DIPT("B",PRCPOPT)) Q:$E(PRCPOPT,1,4)'="PRCP"!($E(PRCPOPT,1,5)="PRCPZ") S PRCPDA=0 F S PRCPDA=$O(^DIPT("B",PRCPOPT,PRCPDA)) Q:'PRCPDA D
. W !?9,PRCPOPT S DIK="^DIPT(",DA=PRCPDA D ^DIK W " deleted!"
;
; clean inventory dd field descriptions
D DESCRIP^PRC5INS1(445,447)
W !!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCP5PRE 2406 printed Sep 23, 2025@19:48:35 Page 2
PRCP5PRE ;WISC/RFJ-pre init for inventory version 5 ;29 Jun 94
+1 ;;5.0;IFCAP;;4/21/95
+2 ;
+3 ;
START ; start pre init to delete all PRCP options (except PRCPZ)
+1 NEW %,DA,DIK,DIU,MENUDA,MENUDA1,PRCPDA,PRCPOPT,X
+2 KILL X
SET X(1)="This pre-init to the Generic Inventory Package will delete all PRCP options (except PRCPZ) from the OPTION file. It will also clean up all menu pointers which reference the deleted PRCP options."
+3 SET X(2)="The pre-init to the Generic Inventory Package will also delete all PRCP input templates, sort templates, and print templates except the PRCPZ namespaced entries."
DO DISPLAY^PRCPUX2(1,78,.X)
+4 ;
+5 WRITE !
SET PRCPOPT="PRCP"
FOR
SET PRCPOPT=$ORDER(^DIC(19,"B",PRCPOPT))
if $EXTRACT(PRCPOPT,1,4)'="PRCP"!($EXTRACT(PRCPOPT,1,5)="PRCPZ")
QUIT
SET PRCPDA=0
FOR
SET PRCPDA=$ORDER(^DIC(19,"B",PRCPOPT,PRCPDA))
if 'PRCPDA
QUIT
Begin DoDot:1
+6 IF PRCPOPT="PRCP MAIN MENU"!(PRCPOPT="PRCP2 MAIN MENU")!(PRCPOPT="PRCPW MAIN MENU")!(PRCPOPT="PRCP ALL")
QUIT
+7 ; do not delete queued taskman options
+8 IF PRCPOPT="PRCP OPEN BALANCES TASKMAN SET"!(PRCPOPT="PRCP PURGE AUTOMATIC RUN")
QUIT
+9 WRITE !," deleting option: ",PRCPOPT
+10 ; clean up menus first
+11 SET MENUDA=0
FOR
SET MENUDA=$ORDER(^DIC(19,"AD",PRCPDA,MENUDA))
if 'MENUDA
QUIT
SET MENUDA1=0
FOR
SET MENUDA1=$ORDER(^DIC(19,"AD",PRCPDA,MENUDA,MENUDA1))
if 'MENUDA1
QUIT
Begin DoDot:2
+12 NEW DA,DIK
SET DIK="^DIC(19,"_MENUDA_",10,"
SET DA(1)=MENUDA
SET DA=MENUDA1
DO ^DIK
QUIT
End DoDot:2
+13 ; remove option
+14 SET DIK="^DIC(19,"
SET DA=PRCPDA
DO ^DIK
WRITE " deleted!"
End DoDot:1
+15 ;
+16 ; delete input, sort, and print templates
+17 WRITE !!,"deleting INPUT TEMPLATES:"
SET PRCPOPT="PRCP"
FOR
SET PRCPOPT=$ORDER(^DIE("B",PRCPOPT))
if $EXTRACT(PRCPOPT,1,4)'="PRCP"!($EXTRACT(PRCPOPT,1,5)="PRCPZ")
QUIT
SET PRCPDA=0
FOR
SET PRCPDA=$ORDER(^DIE("B",PRCPOPT,PRCPDA))
if 'PRCPDA
QUIT
Begin DoDot:1
+18 WRITE !?9,PRCPOPT
SET DIK="^DIE("
SET DA=PRCPDA
DO ^DIK
WRITE " deleted!"
End DoDot:1
+19 WRITE !!,"deleting SORT TEMPLATES:"
SET PRCPOPT="PRCP"
FOR
SET PRCPOPT=$ORDER(^DIBT("B",PRCPOPT))
if $EXTRACT(PRCPOPT,1,4)'="PRCP"!($EXTRACT(PRCPOPT,1,5)="PRCPZ")
QUIT
SET PRCPDA=0
FOR
SET PRCPDA=$ORDER(^DIBT("B",PRCPOPT,PRCPDA))
if 'PRCPDA
QUIT
Begin DoDot:1
+20 WRITE !?9,PRCPOPT
SET DIK="^DIBT("
SET DA=PRCPDA
DO ^DIK
WRITE " deleted!"
End DoDot:1
+21 WRITE !!,"deleting PRINT TEMPLATES:"
SET PRCPOPT="PRCP"
FOR
SET PRCPOPT=$ORDER(^DIPT("B",PRCPOPT))
if $EXTRACT(PRCPOPT,1,4)'="PRCP"!($EXTRACT(PRCPOPT,1,5)="PRCPZ")
QUIT
SET PRCPDA=0
FOR
SET PRCPDA=$ORDER(^DIPT("B",PRCPOPT,PRCPDA))
if 'PRCPDA
QUIT
Begin DoDot:1
+22 WRITE !?9,PRCPOPT
SET DIK="^DIPT("
SET DA=PRCPDA
DO ^DIK
WRITE " deleted!"
End DoDot:1
+23 ;
+24 ; clean inventory dd field descriptions
+25 DO DESCRIP^PRC5INS1(445,447)
+26 WRITE !!
+27 QUIT
