101 lines
4.6 KiB
Mathematica
101 lines
4.6 KiB
Mathematica
PRCPUINV ;WISC/RFJ/DGL-inventory point selection ; 9/20/06 11:04am
|
|
V ;;5.1;IFCAP;**1,98**;Oct 20, 2000;Build 37
|
|
;Per VHA Directive 2004-038, this routine should not be modified.
|
|
Q
|
|
;
|
|
;
|
|
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 %=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 !!
|
|
Q
|
|
;
|
|
;PRCPUINV
|