PRCP5POS ;WISC/RFJ-post init for inventory version 5 ;29 Jun 94
;;5.0;IFCAP;;4/21/95
;
;
START ; start post init
N DA,DATA,DIK,INVPT,ITEMDA,ITEMDATA,PRCPX,X
; clean up due-ins and due-outs
W !!,"Looping inventory points and items, copying due-ins/outs to new fields",!
S INVPT=0 F S INVPT=$O(^PRCP(445,INVPT)) Q:'INVPT W "." S ITEMDA=0 F S ITEMDA=$O(^PRCP(445,INVPT,1,ITEMDA)) Q:'ITEMDA S ITEMDATA=$G(^PRCP(445,INVPT,1,ITEMDA,0)) I ITEMDATA'="",'$D(^PRCP(445,INVPT,1,ITEMDA,"DUE")) D
. S ^PRCP(445,INVPT,1,ITEMDA,"DUE")=+$P(ITEMDATA,"^",8)_"^"_+$P(ITEMDATA,"^",20)
. S $P(^PRCP(445,INVPT,1,ITEMDA,0),"^",8)="",$P(^PRCP(445,INVPT,1,ITEMDA,0),"^",20)=""
; set due-outs in secondaries to zero
S INVPT=0 F S INVPT=$O(^PRCP(445,INVPT)) Q:'INVPT W "." I $P($G(^(INVPT,0)),"^",3)="S" S ITEMDA=0 F S ITEMDA=$O(^PRCP(445,INVPT,1,ITEMDA)) Q:'ITEMDA I $D(^PRCP(445,INVPT,1,ITEMDA,"DUE")) S $P(^("DUE"),"^",2)=0
; redirect barcode pointers
S X=$O(^PRCT(446.6,"B","INTERMEC TRAKKER 9440",0)) I X S %=0 F S %=$O(^PRCT(446.4,%)) Q:'% I $D(^PRCT(446.4,%,0)) S $P(^(0),"^",9)=X
S X=$O(^PRCT(446.6,"B","LABEL 3X1/INTERMEC 8646",0)) I X S %=0 F S %=$O(^PRCT(446.5,%)) Q:'% I $D(^PRCT(446.5,%,0)) S $P(^(0),"^",6)=X
; change barcode routine prcpubar to prcpbalm
S X=0 F S X=$O(^PRCT(446.4,X)) Q:'X S %=$P($G(^(X,0)),"^",4) I %["PRCPBAR" S $P(^PRCT(446.4,X,0),"^",4)=$S(%="EN1-PRCPBAR":"PHYSICAL-PRCPBALM",%="EN2-PRCPBAR":"USAGE-PRCPBALM",1:"")
; recompile print labels
F PRCPX="PRIMARY/SECONDARY LABEL","WAREHOUSE LABEL","TEST/LABEL 3X1","EXPENDABLE INVENTORY","RUN IRL PROGRAM" S DA=+$O(^PRCT(446.5,"B",PRCPX,0)) I $D(^PRCT(446.5,DA,0)) D
. I PRCPX="TEST/LABEL 3X1",'$D(^PRC(440,0)) Q
. D COMP^PRCTRED
; clean dd's
K ^DD(445.121,0,"ID","WRITE")
K ^DD(445.121,0,"NM","MEMBER OF SET/PACK")
; add PRCP options which were deleted from PRC
N %,ADDOPT,DISPLAY,OPTION,PRCPOPT
F %=1:1 S X=$P($T(OPTION+%),";",3,99) Q:X="" S OPTION(%)=$O(^DIC(19,"B",$P(X,"^"),0)),DISPLAY(%)=$P(X,"^",2,3)
S PRCPOPT=$O(^DIC(19,"B","PRCHPM RA MENU",0)) I PRCPOPT F ADDOPT=1 I OPTION(ADDOPT) D ADDOPT(PRCPOPT,OPTION(ADDOPT),+$P(DISPLAY(ADDOPT),"^"))
S PRCPOPT=$O(^DIC(19,"B","PRCHUSER PPM",0)) I PRCPOPT F ADDOPT=1 I OPTION(ADDOPT) D ADDOPT(PRCPOPT,OPTION(ADDOPT),+$P(DISPLAY(ADDOPT),"^",2))
S PRCPOPT=$O(^DIC(19,"B","PRCHUSER COORDINATOR",0)) I PRCPOPT,OPTION(2) D ADDOPT(PRCPOPT,OPTION(2),0)
; run inits for list manager
S X="PRCPL" X:$D(^%ZOSF("TEST")) ^("TEST") I $T D ^PRCPL
S X="PRCPONIT" X:$D(^%ZOSF("TEST")) ^("TEST") I $T D ^PRCPONIT
; re-index new cross-references
S DIK="^PRCP(445,",DIK(1)=15 D ENALL^DIK
S DIK="^PRCP(445.2,",DIK(1)=3 D ENALL^DIK
S DIK="^PRCP(445.2,",DIK(1)=13 D ENALL^DIK
Q
;
;
ADDOPT(V1,V2,V3) ;add option da=v2 to menu option da=v1 ; display order=v3
; option is already in the menu
I $O(^DIC(19,V1,10,"B",V2,0)) Q
I '$D(^DIC(19,V1,0))!('$D(^DIC(19,V2,0))) Q
N D0,DA,DD,DI,DIC,DIE,DLAYGO,DQ,DR,X,Y
I '$D(^DIC(19,V1,10,0)) S ^(0)="^19.01PI^^"
S DIC="^DIC(19,"_V1_",10,",DIC(0)="L",DLAYGO=19,DA(1)=V1,X=V2 S:V3 DIC("DR")="3///"_V3 D FILE^DICN
Q
;
;
;;option to add ^ display order (prchpm ra menu) ^ display order (prchuser ppm)
OPTION ;;options to add to menus
;;PRCP PPM MENU^20^35
;;PRCP POSTED DIETETIC REPORT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCP5POS 3351 printed Nov 22, 2024@17:22:35 Page 2
PRCP5POS ;WISC/RFJ-post init for inventory version 5 ;29 Jun 94
+1 ;;5.0;IFCAP;;4/21/95
+2 ;
+3 ;
START ; start post init
+1 NEW DA,DATA,DIK,INVPT,ITEMDA,ITEMDATA,PRCPX,X
+2 ; clean up due-ins and due-outs
+3 WRITE !!,"Looping inventory points and items, copying due-ins/outs to new fields",!
+4 SET INVPT=0
FOR
SET INVPT=$ORDER(^PRCP(445,INVPT))
if 'INVPT
QUIT
WRITE "."
SET ITEMDA=0
FOR
SET ITEMDA=$ORDER(^PRCP(445,INVPT,1,ITEMDA))
if 'ITEMDA
QUIT
SET ITEMDATA=$GET(^PRCP(445,INVPT,1,ITEMDA,0))
IF ITEMDATA'=""
IF '$DATA(^PRCP(445,INVPT,1,ITEMDA,"DUE"))
Begin DoDot:1
+5 SET ^PRCP(445,INVPT,1,ITEMDA,"DUE")=+$PIECE(ITEMDATA,"^",8)_"^"_+$PIECE(ITEMDATA,"^",20)
+6 SET $PIECE(^PRCP(445,INVPT,1,ITEMDA,0),"^",8)=""
SET $PIECE(^PRCP(445,INVPT,1,ITEMDA,0),"^",20)=""
End DoDot:1
+7 ; set due-outs in secondaries to zero
+8 SET INVPT=0
FOR
SET INVPT=$ORDER(^PRCP(445,INVPT))
if 'INVPT
QUIT
WRITE "."
IF $PIECE($GET(^(INVPT,0)),"^",3)="S"
SET ITEMDA=0
FOR
SET ITEMDA=$ORDER(^PRCP(445,INVPT,1,ITEMDA))
if 'ITEMDA
QUIT
IF $DATA(^PRCP(445,INVPT,1,ITEMDA,"DUE"))
SET $PIECE(^("DUE"),"^",2)=0
+9 ; redirect barcode pointers
+10 SET X=$ORDER(^PRCT(446.6,"B","INTERMEC TRAKKER 9440",0))
IF X
SET %=0
FOR
SET %=$ORDER(^PRCT(446.4,%))
if '%
QUIT
IF $DATA(^PRCT(446.4,%,0))
SET $PIECE(^(0),"^",9)=X
+11 SET X=$ORDER(^PRCT(446.6,"B","LABEL 3X1/INTERMEC 8646",0))
IF X
SET %=0
FOR
SET %=$ORDER(^PRCT(446.5,%))
if '%
QUIT
IF $DATA(^PRCT(446.5,%,0))
SET $PIECE(^(0),"^",6)=X
+12 ; change barcode routine prcpubar to prcpbalm
+13 SET X=0
FOR
SET X=$ORDER(^PRCT(446.4,X))
if 'X
QUIT
SET %=$PIECE($GET(^(X,0)),"^",4)
IF %["PRCPBAR"
SET $PIECE(^PRCT(446.4,X,0),"^",4)=$SELECT(%="EN1-PRCPBAR":"PHYSICAL-PRCPBALM",%="EN2-PRCPBAR":"USAGE-PRCPBALM",1:"")
+14 ; recompile print labels
+15 FOR PRCPX="PRIMARY/SECONDARY LABEL","WAREHOUSE LABEL","TEST/LABEL 3X1","EXPENDABLE INVENTORY","RUN IRL PROGRAM"
SET DA=+$ORDER(^PRCT(446.5,"B",PRCPX,0))
IF $DATA(^PRCT(446.5,DA,0))
Begin DoDot:1
+16 IF PRCPX="TEST/LABEL 3X1"
IF '$DATA(^PRC(440,0))
QUIT
+17 DO COMP^PRCTRED
End DoDot:1
+18 ; clean dd's
+19 KILL ^DD(445.121,0,"ID","WRITE")
+20 KILL ^DD(445.121,0,"NM","MEMBER OF SET/PACK")
+21 ; add PRCP options which were deleted from PRC
+22 NEW %,ADDOPT,DISPLAY,OPTION,PRCPOPT
+23 FOR %=1:1
SET X=$PIECE($TEXT(OPTION+%),";",3,99)
if X=""
QUIT
SET OPTION(%)=$ORDER(^DIC(19,"B",$PIECE(X,"^"),0))
SET DISPLAY(%)=$PIECE(X,"^",2,3)
+24 SET PRCPOPT=$ORDER(^DIC(19,"B","PRCHPM RA MENU",0))
IF PRCPOPT
FOR ADDOPT=1
IF OPTION(ADDOPT)
DO ADDOPT(PRCPOPT,OPTION(ADDOPT),+$PIECE(DISPLAY(ADDOPT),"^"))
+25 SET PRCPOPT=$ORDER(^DIC(19,"B","PRCHUSER PPM",0))
IF PRCPOPT
FOR ADDOPT=1
IF OPTION(ADDOPT)
DO ADDOPT(PRCPOPT,OPTION(ADDOPT),+$PIECE(DISPLAY(ADDOPT),"^",2))
+26 SET PRCPOPT=$ORDER(^DIC(19,"B","PRCHUSER COORDINATOR",0))
IF PRCPOPT
IF OPTION(2)
DO ADDOPT(PRCPOPT,OPTION(2),0)
+27 ; run inits for list manager
+28 SET X="PRCPL"
if $DATA(^%ZOSF("TEST"))
XECUTE ^("TEST")
IF $TEST
DO ^PRCPL
+29 SET X="PRCPONIT"
if $DATA(^%ZOSF("TEST"))
XECUTE ^("TEST")
IF $TEST
DO ^PRCPONIT
+30 ; re-index new cross-references
+31 SET DIK="^PRCP(445,"
SET DIK(1)=15
DO ENALL^DIK
+32 SET DIK="^PRCP(445.2,"
SET DIK(1)=3
DO ENALL^DIK
+33 SET DIK="^PRCP(445.2,"
SET DIK(1)=13
DO ENALL^DIK
+34 QUIT
+35 ;
+36 ;
ADDOPT(V1,V2,V3) ;add option da=v2 to menu option da=v1 ; display order=v3
+1 ; option is already in the menu
+2 IF $ORDER(^DIC(19,V1,10,"B",V2,0))
QUIT
+3 IF '$DATA(^DIC(19,V1,0))!('$DATA(^DIC(19,V2,0)))
QUIT
+4 NEW D0,DA,DD,DI,DIC,DIE,DLAYGO,DQ,DR,X,Y
+5 IF '$DATA(^DIC(19,V1,10,0))
SET ^(0)="^19.01PI^^"
+6 SET DIC="^DIC(19,"_V1_",10,"
SET DIC(0)="L"
SET DLAYGO=19
SET DA(1)=V1
SET X=V2
if V3
SET DIC("DR")="3///"_V3
DO FILE^DICN
+7 QUIT
+8 ;
+9 ;
+10 ;;option to add ^ display order (prchpm ra menu) ^ display order (prchuser ppm)
OPTION ;;options to add to menus
+1 ;;PRCP PPM MENU^20^35
+2 ;;PRCP POSTED DIETETIC REPORT
