PRCPUINV ;WISC/RFJ/DGL-inventory point selection ; 9/20/06 11:04am
V ;;5.1;IFCAP;**1,98,179**;Oct 20, 2000;Build 6
;Per VHA Directive 2004-038, this routine should not be modified.
Q
;
;PRC*5.1*179 Modify secondary delete process to prevent site overwrite
; when killing links to fund control points
;
INVPT(PRCPSITE,PRCPTYPE,ADDNEW,PRCPUSER,DEFAULT) ; select inventory point
; prcptype=w or p or s
; addnew =1 to add new inventory points
; prcpuser=1 to screen and set user
; default =default inventory point
; return da; 0 no item selected; ^ for ^ entered or timeout
I 'PRCPSITE!("WPS"'[PRCPTYPE) Q ""
N %,D0,DA,DI,DIE,DG,DIC,DISYS,DLAYGO,DQ,DR,PRC,PRCPPRIV,X,Y
S PRC("SITE")=PRCPSITE
; do not allow adding new entries for whse if defined
I PRCPTYPE="W" F %=0:0 S %=$O(^PRCP(445,"AC","W",%)) Q:'% I +$G(^PRCP(445,%,0))=PRCPSITE S ADDNEW=0 Q
S DIC="^PRCP(445,",DIC(0)="QEAM",DIC("A")="Select a '"_$S(PRCPTYPE="W":"Warehouse",PRCPTYPE="P":"Primary",1:"Secondary")_"' Type Inventory Point: "
I DEFAULT'="" S DIC("B")=DEFAULT
I ADDNEW S DIC(0)="QEALM",DLAYGO=445,DIC("DR")=".8;.7///"_PRCPTYPE_";.5//"_$S(PRCPTYPE="S":"NO",1:"YES")_";.6//"_$S(PRCPTYPE="S":"NO",1:"YES")_";"_$S(PRCPTYPE="S":"",1:".9;")
S DIC("S")="I +^(0)=PRCPSITE,$P(^(0),U,3)=PRCPTYPE"_$S(PRCPUSER:",$D(^PRCP(445,+Y,4,+$G(DUZ),0))",1:""),PRCPPRIV=1
W ! D ^DIC
; if new entry added, add authorized user
I $P(Y,"^",3),$G(DUZ),PRCPUSER D
. D ADDUSER^PRCPXTRM(+Y,DUZ)
. W !?2,"TYPE OF INVENTORY POINT: ",$S(PRCPTYPE="W":"WAREHOUSE",PRCPTYPE="P":"PRIMARY",1:"SECONDARY")
Q $S($G(DUOUT):"^",$G(DTOUT):"^",Y<1:0,1:+Y)
;
;
TYPE ; called from 445,.7 input transform. you cannot have
; multiple warehouses with the same station number
N STATION,%
S STATION=+$G(^PRCP(445,DA,0)),%=0
F S %=$O(^PRCP(445,"AC","W",%)) Q:'% I %'=DA,+$G(^PRCP(445,%,0))=STATION W !?2,"YOU CANNOT HAVE MULTIPLE WAREHOUSES WITH THE SAME STATION NUMBER." K X Q
Q
;
;
KILL(INVPT) ; update all pointers when deleting an inventory point
; (invoked from 'DEL' node in .01 field of file 445)
;
N %,DATA,NAME,OUTORD,X
S XP(1)="You cannot delete inventory points after they are created."
S XP(2)="This action removes all the items, distribution points, users,"
S XP(3)="etc., for the inventory point and changes the name to"
S XP(4)="STATIONNUMBER-'***INACTIVE_#***' where # is the internal entry number."
S XP="",XP(5)="",XP(6)=" ARE YOU SURE YOU WANT TO PROCEED"
I $$YN^PRCPUYN(2)'=1 Q
;
; quit if this inventory point has outstanding distribution orders
S DATA=$P(^PRCP(445,INVPT,0),"^",3) ; search for primary or secondary
I DATA="P"!(DATA="S") D I OUTORD Q
. S OUTORD=$$ORDCHK^PRCPUITM(0,INVPT,"REC","")
. I OUTORD D Q
. . D EN^DDIOL("You must first post or delete outstanding orders for this inventory point.")
. . I +$G(DQ) S DE(+$G(DQ))=$P($G(^PRCP(445,INVPT,0)),"^",1)
. . W !!
;
; if the inventory point is linked to a supply station
I $P($G(^PRCP(445,INVPT,5)),"^",1)]"" D Q
. D EN^DDIOL("This inventory point is linked to a supply station.")
. D EN^DDIOL("You must first delete the Supply Station Provider.")
;
W !?3,"Wait, deleting data, changing name, etc..."
S DATA=$P($G(^PRCP(445,INVPT,5)),"^",1) ; supply station
I DATA K ^PRCP(445,"AI",DATA,INVPT)
; remove x-ref on inventory points
S %=0 F S %=$O(^PRCP(445,INVPT,2,%)) Q:'% K ^PRCP(445,"AB",%,INVPT,%)
; remove x-ref on inventory,ODI users ("AJ" (ODI) from PRC*5.1*98)
S %=0 F S %=$O(^PRCP(445,INVPT,4,%)) Q:'% K ^PRCP(445,"AD",%,INVPT,%)
S %=0 F S %=$O(^PRCP(445,INVPT,9,%)) Q:'% K ^PRCP(445,"AJ",%,INVPT,%)
; remove x-ref on items
S %=0 F S %=$O(^PRCP(445,INVPT,1,%)) Q:'% D
. K ^PRCP(445,"AE",%,INVPT,%)
. I DATA K ^PRCP(445,"AH",%,DATA,INVPT)
; change name, etc
S X=^PRCP(445,INVPT,0),NAME=$P(X,"^")
S:$P(NAME,"-",2,99)="" $P(NAME,"-",2,99)=" "
S:$P(X,"^",5)="" $P(X,"^",5)=" "
K ^PRCP(445,"AF",+X,$P(X,"^",5),INVPT)
K ^PRCP(445,"B",$P(X,"^"),INVPT)
K ^PRCP(445,"C",$P(NAME,"-",2,99),INVPT)
K ^PRCP(445,INVPT)
S $P(NAME,"-",2,99)="***INACTIVE_"_INVPT_"***"
S ^PRCP(445,"B",NAME,INVPT)=""
S ^PRCP(445,"C",$P(NAME,"-",2),INVPT)=""
S ^PRCP(445,INVPT,0)=NAME_"^N^"_$P(X,"^",3)_"^^^N"
W !?5,"Name changed to: ",NAME
;
W !?3,"Removing as a distribution point for the following inventory points:"
S %=0 F S %=$O(^PRCP(445,"AB",INVPT,%)) Q:'% I $D(^PRCP(445,%,2,INVPT)) W !?5,$$INVNAME^PRCPUX1(%) K ^PRCP(445,%,2,INVPT) I $D(^PRCP(445,%,2,0)) S X=^(0) D
. S $P(X,"^",4)=$P(X,"^",4)-1 S:$P(X,"^",4)<0 $P(X,"^",4)=0 S:$P(X,"^",3)=INVPT $P(X,"^",3)="" S ^PRCP(445,%,2,0)=X
K ^PRCP(445,"AB",INVPT)
;
W !?3,"Removing link to the following fund control points:"
S PRCPSTHH=PRC("SITE") ;PRC*5.1*179 save original site
S %=0 F S %=$O(^PRC(420,"AE",%)) Q:'% S PRC("SITE")=%,X=0 F S X=$O(^PRC(420,"AE",%,INVPT,X)) Q:'X W !?5,%,"-",X D DEL^PRCPUFCP(X,INVPT)
I +$G(DQ) S DE(+$G(DQ))=NAME
W !!
S PRC("SITE")=PRCPSTHH K PRCPSTHH ;PRC*5.1*179 restore original site
Q
;
;PRCPUINV
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPUINV 5125 printed Dec 13, 2024@02:16:11 Page 2
PRCPUINV ;WISC/RFJ/DGL-inventory point selection ; 9/20/06 11:04am
V ;;5.1;IFCAP;**1,98,179**;Oct 20, 2000;Build 6
+1 ;Per VHA Directive 2004-038, this routine should not be modified.
+2 QUIT
+3 ;
+4 ;PRC*5.1*179 Modify secondary delete process to prevent site overwrite
+5 ; when killing links to fund control points
+6 ;
INVPT(PRCPSITE,PRCPTYPE,ADDNEW,PRCPUSER,DEFAULT) ; select inventory point
+1 ; prcptype=w or p or s
+2 ; addnew =1 to add new inventory points
+3 ; prcpuser=1 to screen and set user
+4 ; default =default inventory point
+5 ; return da; 0 no item selected; ^ for ^ entered or timeout
+6 IF 'PRCPSITE!("WPS"'[PRCPTYPE)
QUIT ""
+7 NEW %,D0,DA,DI,DIE,DG,DIC,DISYS,DLAYGO,DQ,DR,PRC,PRCPPRIV,X,Y
+8 SET PRC("SITE")=PRCPSITE
+9 ; do not allow adding new entries for whse if defined
+10 IF PRCPTYPE="W"
FOR %=0:0
SET %=$ORDER(^PRCP(445,"AC","W",%))
if '%
QUIT
IF +$GET(^PRCP(445,%,0))=PRCPSITE
SET ADDNEW=0
QUIT
+11 SET DIC="^PRCP(445,"
SET DIC(0)="QEAM"
SET DIC("A")="Select a '"_$SELECT(PRCPTYPE="W":"Warehouse",PRCPTYPE="P":"Primary",1:"Secondary")_"' Type Inventory Point: "
+12 IF DEFAULT'=""
SET DIC("B")=DEFAULT
+13 IF ADDNEW
SET DIC(0)="QEALM"
SET DLAYGO=445
SET DIC("DR")=".8;.7///"_PRCPTYPE_";.5//"_$SELECT(PRCPTYPE="S":"NO",1:"YES")_";.6//"_$SELECT(PRCPTYPE="S":"NO",1:"YES")_";"_$SELECT(PRCPTYPE="S":"",1:".9;")
+14 SET DIC("S")="I +^(0)=PRCPSITE,$P(^(0),U,3)=PRCPTYPE"_$SELECT(PRCPUSER:",$D(^PRCP(445,+Y,4,+$G(DUZ),0))",1:"")
SET PRCPPRIV=1
+15 WRITE !
DO ^DIC
+16 ; if new entry added, add authorized user
+17 IF $PIECE(Y,"^",3)
IF $GET(DUZ)
IF PRCPUSER
Begin DoDot:1
+18 DO ADDUSER^PRCPXTRM(+Y,DUZ)
+19 WRITE !?2,"TYPE OF INVENTORY POINT: ",$SELECT(PRCPTYPE="W":"WAREHOUSE",PRCPTYPE="P":"PRIMARY",1:"SECONDARY")
End DoDot:1
+20 QUIT $SELECT($GET(DUOUT):"^",$GET(DTOUT):"^",Y<1:0,1:+Y)
+21 ;
+22 ;
TYPE ; called from 445,.7 input transform. you cannot have
+1 ; multiple warehouses with the same station number
+2 NEW STATION,%
+3 SET STATION=+$GET(^PRCP(445,DA,0))
SET %=0
+4 FOR
SET %=$ORDER(^PRCP(445,"AC","W",%))
if '%
QUIT
IF %'=DA
IF +$GET(^PRCP(445,%,0))=STATION
WRITE !?2,"YOU CANNOT HAVE MULTIPLE WAREHOUSES WITH THE SAME STATION NUMBER."
KILL X
QUIT
+5 QUIT
+6 ;
+7 ;
KILL(INVPT) ; update all pointers when deleting an inventory point
+1 ; (invoked from 'DEL' node in .01 field of file 445)
+2 ;
+3 NEW %,DATA,NAME,OUTORD,X
+4 SET XP(1)="You cannot delete inventory points after they are created."
+5 SET XP(2)="This action removes all the items, distribution points, users,"
+6 SET XP(3)="etc., for the inventory point and changes the name to"
+7 SET XP(4)="STATIONNUMBER-'***INACTIVE_#***' where # is the internal entry number."
+8 SET XP=""
SET XP(5)=""
SET XP(6)=" ARE YOU SURE YOU WANT TO PROCEED"
+9 IF $$YN^PRCPUYN(2)'=1
QUIT
+10 ;
+11 ; quit if this inventory point has outstanding distribution orders
+12 ; search for primary or secondary
SET DATA=$PIECE(^PRCP(445,INVPT,0),"^",3)
+13 IF DATA="P"!(DATA="S")
Begin DoDot:1
+14 SET OUTORD=$$ORDCHK^PRCPUITM(0,INVPT,"REC","")
+15 IF OUTORD
Begin DoDot:2
+16 DO EN^DDIOL("You must first post or delete outstanding orders for this inventory point.")
+17 IF +$GET(DQ)
SET DE(+$GET(DQ))=$PIECE($GET(^PRCP(445,INVPT,0)),"^",1)
+18 WRITE !!
End DoDot:2
QUIT
End DoDot:1
IF OUTORD
QUIT
+19 ;
+20 ; if the inventory point is linked to a supply station
+21 IF $PIECE($GET(^PRCP(445,INVPT,5)),"^",1)]""
Begin DoDot:1
+22 DO EN^DDIOL("This inventory point is linked to a supply station.")
+23 DO EN^DDIOL("You must first delete the Supply Station Provider.")
End DoDot:1
QUIT
+24 ;
+25 WRITE !?3,"Wait, deleting data, changing name, etc..."
+26 ; supply station
SET DATA=$PIECE($GET(^PRCP(445,INVPT,5)),"^",1)
+27 IF DATA
KILL ^PRCP(445,"AI",DATA,INVPT)
+28 ; remove x-ref on inventory points
+29 SET %=0
FOR
SET %=$ORDER(^PRCP(445,INVPT,2,%))
if '%
QUIT
KILL ^PRCP(445,"AB",%,INVPT,%)
+30 ; remove x-ref on inventory,ODI users ("AJ" (ODI) from PRC*5.1*98)
+31 SET %=0
FOR
SET %=$ORDER(^PRCP(445,INVPT,4,%))
if '%
QUIT
KILL ^PRCP(445,"AD",%,INVPT,%)
+32 SET %=0
FOR
SET %=$ORDER(^PRCP(445,INVPT,9,%))
if '%
QUIT
KILL ^PRCP(445,"AJ",%,INVPT,%)
+33 ; remove x-ref on items
+34 SET %=0
FOR
SET %=$ORDER(^PRCP(445,INVPT,1,%))
if '%
QUIT
Begin DoDot:1
+35 KILL ^PRCP(445,"AE",%,INVPT,%)
+36 IF DATA
KILL ^PRCP(445,"AH",%,DATA,INVPT)
End DoDot:1
+37 ; change name, etc
+38 SET X=^PRCP(445,INVPT,0)
SET NAME=$PIECE(X,"^")
+39 if $PIECE(NAME,"-",2,99)=""
SET $PIECE(NAME,"-",2,99)=" "
+40 if $PIECE(X,"^",5)=""
SET $PIECE(X,"^",5)=" "
+41 KILL ^PRCP(445,"AF",+X,$PIECE(X,"^",5),INVPT)
+42 KILL ^PRCP(445,"B",$PIECE(X,"^"),INVPT)
+43 KILL ^PRCP(445,"C",$PIECE(NAME,"-",2,99),INVPT)
+44 KILL ^PRCP(445,INVPT)
+45 SET $PIECE(NAME,"-",2,99)="***INACTIVE_"_INVPT_"***"
+46 SET ^PRCP(445,"B",NAME,INVPT)=""
+47 SET ^PRCP(445,"C",$PIECE(NAME,"-",2),INVPT)=""
+48 SET ^PRCP(445,INVPT,0)=NAME_"^N^"_$PIECE(X,"^",3)_"^^^N"
+49 WRITE !?5,"Name changed to: ",NAME
+50 ;
+51 WRITE !?3,"Removing as a distribution point for the following inventory points:"
+52 SET %=0
FOR
SET %=$ORDER(^PRCP(445,"AB",INVPT,%))
if '%
QUIT
IF $DATA(^PRCP(445,%,2,INVPT))
WRITE !?5,$$INVNAME^PRCPUX1(%)
KILL ^PRCP(445,%,2,INVPT)
IF $DATA(^PRCP(445,%,2,0))
SET X=^(0)
Begin DoDot:1
+53 SET $PIECE(X,"^",4)=$PIECE(X,"^",4)-1
if $PIECE(X,"^",4)<0
SET $PIECE(X,"^",4)=0
if $PIECE(X,"^",3)=INVPT
SET $PIECE(X,"^",3)=""
SET ^PRCP(445,%,2,0)=X
End DoDot:1
+54 KILL ^PRCP(445,"AB",INVPT)
+55 ;
+56 WRITE !?3,"Removing link to the following fund control points:"
+57 ;PRC*5.1*179 save original site
SET PRCPSTHH=PRC("SITE")
+58 SET %=0
FOR
SET %=$ORDER(^PRC(420,"AE",%))
if '%
QUIT
SET PRC("SITE")=%
SET X=0
FOR
SET X=$ORDER(^PRC(420,"AE",%,INVPT,X))
if 'X
QUIT
WRITE !?5,%,"-",X
DO DEL^PRCPUFCP(X,INVPT)
+59 IF +$GET(DQ)
SET DE(+$GET(DQ))=NAME
+60 WRITE !!
+61 ;PRC*5.1*179 restore original site
SET PRC("SITE")=PRCPSTHH
KILL PRCPSTHH
+62 QUIT
+63 ;
+64 ;PRCPUINV
