PRCPOPUS ;WISC/RFJ-utility: distribution order selection ; 5/5/99 10:25am
V ;;5.1;IFCAP;**1**;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
;
ADDNEW(ORDER,PRCPPRIM,PRCPSECO) ; add new distribution order number ORDER
; returns distribution order
N %,%DT,C,D0,DA,DD,DI,DIC,DIE,DLAYGO,DQ,DR,X,Y
S DIC="^PRCP(445.3,",DIC("DR")="1////"_(+PRCPPRIM)_";2////"_(+PRCPSECO)_";3///TODAY;3.5////R;4////"_DUZ,DIC(0)="LZ",DLAYGO=445.3,X=+ORDER,PRCPPRIV=1 D FILE^DICN K PRCPPRIV
Q $S(+Y>0:+Y,1:0)
;
;
NEWORDER(PRCPPRIM) ; get next order number for primary
; called from 445.3,.01 input transform when entering 'new'.
; returns variable x = new order
I '$D(^PRCP(445,+PRCPPRIM,0)) K X Q
N END,FLAG,Z
L +^PRCP(445.3,"ANXT",PRCPPRIM)
S (END,X)=+$G(^PRCP(445.3,"ANXT",PRCPPRIM))
F S X=X+1 Q:X=END S:X>999999 X=1 Q:'$D(^PRCP(445.3,"B",X)) D Q:'$G(FLAG)
. K FLAG S Z=0 F S Z=$O(^PRCP(445.3,"B",X,Z)) Q:'Z I $D(^PRCP(445.3,"AC",PRCPPRIM,Z)) S FLAG=1 Q
S ^PRCP(445.3,"ANXT",PRCPPRIM)=X
L -^PRCP(445.3,"ANXT",PRCPPRIM)
I X=END W !!?10,"YOU NEED TO DELETE SOME OF THE OLD ORDERS FIRST!" K X
Q
;
;
ORDERSEL(PRCPPRIM,PRCPSECO,PRCPSTAT,ADDNEW) ; select distribution order
; prcpprim=primary inventory point screen
; prcpseco=secondary inventory point screen
; prcpstat=status for screen (set to * to eliminate screen on status)
; addnew=1 to add new orders
; returns selected distribution order da number
; returns variable prcpfnew if its a newly created order
N %,%H,%I,C,D0,DA,DG,DI,DQ,DIC,DIE,DLAYGO,DR,ORDERDA,PRCPNEW,PRCPPRIV,SCREEN,STATUS,X,Y
K PRCPFNEW
S DIC(0)="AEQM",DIC="^PRCP(445.3,"
S DIC("A")="Select DISTRIBUTION ORDER: "
S PRCPPRIV=1
;
; set up screen
I PRCPPRIM S DIC("S")="I $P(^(0),U,2)="_PRCPPRIM
I PRCPSECO S DIC("S")=$S($G(DIC("S"))="":"I ",1:DIC("S")_",")_"$P(^(0),U,3)="_PRCPSECO
I PRCPSTAT'="*" D
. S DIC("S")=DIC("S")_" S %=$P(^(0),U,6)"
. I PRCPSTAT="" S DIC("S")=DIC("S")_" I %=""""" Q
. S SCREEN=""
. F %=1:1 S STATUS=$P(PRCPSTAT,"!",%) Q:STATUS="" S SCREEN=SCREEN_$S(SCREEN="":"",1:"!")_"(%="_$C(34)_STATUS_$C(34)_")"
. S DIC("S")=DIC("S")_" I "_SCREEN
;
; adding new entries allowed
I ADDNEW S DIC(0)="AEQML",DLAYGO=445.3,DIC("DR")="1////"_PRCPPRIM_$S(PRCPSECO:";2////"_PRCPSECO,1:"")
;
D ^DIC I Y'>0 Q 0
S ORDERDA=+Y
I $P(Y,"^",3) S PRCPFNEW=1
I $G(PRCPFNEW) S $P(^PRCP(445.3,ORDERDA,0),"^",4,5)=DT_"^"_DUZ,$P(^(0),"^",8)="R"
Q ORDERDA
;
;
TYPE(ORDERDA) ; ask order type for orderda
; returns 1 if unsuccessful
I '$D(^PRCP(445.3,+ORDERDA,0)) Q 1
I $P(^PRCP(445.3,+ORDERDA,0),"^",6)="P" Q 0
N %,D,D0,DA,DDH,DI,DIC,DIE,DIR,DQ,DR,DZ,ORD,PRCPEXIT,PRCPPRIV,PRCPSEC,X,Y
; if this is a regular order for a supply station secondary, don't prompt
; if this is an emergency or call-in order for a supply station secondary, allow all selections but regular.
S ORD=0,PRCPEXIT=0
S PRCPSEC=$P($G(^PRCP(445.3,ORDERDA,0)),"^",3)
I $P($G(^PRCP(445,PRCPSEC,5)),"^",1)]"",$D(^PRCP(445.3,ORDERDA,1)) D G TYPEQ:PRCPEXIT
. S ORD=$P($G(^PRCP(445.3,ORDERDA,0)),"^",8)
. I ORD="R" D Q
. . D EN^DDIOL("This is a regular order on a supply station secondary.")
. . D EN^DDIOL("Its 'TYPE OF ORDER' cannot be edited to CALL_IN or EMERGENCY.")
. . S PRCPEXIT=1
. S DIR("A")="TYPE OF ORDER"
. S DIR("A",1)="This order is for a supply station secondary."
. S DIR("A",2)="The order type cannot be changed to regular."
. S DIR(0)="SB^C:CALL-IN;E:EMERGENCY"
. S DIR("B")="CALL-IN" I ORD="E" S DIR("B")="EMERGENCY"
. D ^DIR
. I $D(DUOUT)!$D(DTOUT) S PRCPEXIT=1 Q
. S ORD=0 I Y="E"!(Y="C") S ORD=Y
S (DIE,DIC)="^PRCP(445.3,",DA=ORDERDA,DR="3.5"
I ORD'=0 S DR=DR_"///^S X=ORD"
S PRCPPRIV=1 D ^DIE
I $D(Y) Q 1
TYPEQ Q 0
;
;
; returns 1 if unsuccessful
I '$D(^PRCP(445.3,+ORDERDA,0)) Q 1
I $P(^PRCP(445.3,+ORDERDA,0),"^",6)="P" Q 0
N %,D,D0,DA,DDH,DI,DIC,DIE,DQ,DR,DZ,PRCPPRIV,X,Y
S (DIE,DIC)="^PRCP(445.3,",DA=ORDERDA,DR="8",PRCPPRIV=1 D ^DIE
I $D(Y) Q 1
Q 0
;
;
ITEMSEL(ORDERDA,PRCPPRIM,PRCPADD) ; select item from distribution order
; returns item number selected
N %,C,DA,DDC,DG,DIC,DLAYGO,I,PRCPSET,X,Y
I '$D(^PRCP(445.3,ORDERDA,0)) Q 0
S:'$D(^PRCP(445.3,ORDERDA,1,0)) ^(0)="^445.37PI^^"
S DIC="^PRCP(445.3,"_ORDERDA_",1,",DIC(0)="QEAMZO"
I PRCPADD S DIC(0)="QEALMZO"
S (PRCPSET,DIC("S"))="I $D(^PRCP(445,PRCPPRIM,1,+Y,0))"
; if this is a regular order for a supply station secondary, restrict
; item selection to items stocked in the supply station (i.e. items
; with non-zero normal levels)
I PRCPADD,$P($G(^PRCP(445,$P(^PRCP(445.3,ORDERDA,0),"^",3),5)),"^",1)]"",$P(^PRCP(445.3,ORDERDA,0),"^",8)="R" D
. S PRCPSEC=$P(^PRCP(445.3,ORDERDA,0),"^",3)
. S U="^"
. S (PRCPSET,DIC("S"))=PRCPSET_",$D(^PRCP(445,PRCPSEC,1,+Y,0)),$P(^PRCP(445,PRCPSEC,1,+Y,0),U,9)>0"
S DA(1)=ORDERDA
S DLAYGO=445.3
W ! D ^DIC
Q $S(+Y>0:+Y,1:0)
;
;
ITEMEDIT(ORDERDA,ITEMDA,ASKCOST) ; edit item on distribution order
N D,D0,DA,DI,DIC,DIE,DQ,DR,X,Y
I '$D(^PRCP(445.3,ORDERDA,1,ITEMDA,0)) Q
S (DIC,DIE)="^PRCP(445.3,"_ORDERDA_",1,",DA(1)=ORDERDA,DA=ITEMDA,DR="1;"_$S(ASKCOST:"2;",1:"") D ^DIE
Q
;
;
ITEMADD(ORDERDA,ITEMDA,QTY) ; automatically add items to distribution order
; return item number added or 0 if unsuccessful
N %,D0,DA,DD,DI,DIC,DIE,DLAYGO,DQ,DR,PRCPPRIM,PRCPPRIV,UNITCOST,X,Y
I '$D(^PRCP(445.3,ORDERDA)) Q 0
I 'ITEMDA Q 0
S PRCPPRIM=+$P($G(^PRCP(445.3,ORDERDA,0)),"^",2),UNITCOST=+$P($G(^PRCP(445,PRCPPRIM,1,ITEMDA,0)),"^",22)
I 'PRCPPRIM,'QTY Q 0
I '$D(^PRCP(445.3,ORDERDA,1,0)) S ^(0)="^445.37PI^^"
S DIC("DR")="1///"_QTY_";2///"_UNITCOST
S DIC="^PRCP(445.3,"_ORDERDA_",1,",DA(1)=ORDERDA,DIC(0)="LZ",DLAYGO=445.3,(DINUM,X)=ITEMDA,PRCPPRIV=1 D FILE^DICN
I Y<0 Q 0
Q +Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCPOPUS 5923 printed Nov 22, 2024@17:24:29 Page 2
PRCPOPUS ;WISC/RFJ-utility: distribution order selection ; 5/5/99 10:25am
V ;;5.1;IFCAP;**1**;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 QUIT
+3 ;
+4 ;
ADDNEW(ORDER,PRCPPRIM,PRCPSECO) ; add new distribution order number ORDER
+1 ; returns distribution order
+2 NEW %,%DT,C,D0,DA,DD,DI,DIC,DIE,DLAYGO,DQ,DR,X,Y
+3 SET DIC="^PRCP(445.3,"
SET DIC("DR")="1////"_(+PRCPPRIM)_";2////"_(+PRCPSECO)_";3///TODAY;3.5////R;4////"_DUZ
SET DIC(0)="LZ"
SET DLAYGO=445.3
SET X=+ORDER
SET PRCPPRIV=1
DO FILE^DICN
KILL PRCPPRIV
+4 QUIT $SELECT(+Y>0:+Y,1:0)
+5 ;
+6 ;
NEWORDER(PRCPPRIM) ; get next order number for primary
+1 ; called from 445.3,.01 input transform when entering 'new'.
+2 ; returns variable x = new order
+3 IF '$DATA(^PRCP(445,+PRCPPRIM,0))
KILL X
QUIT
+4 NEW END,FLAG,Z
+5 LOCK +^PRCP(445.3,"ANXT",PRCPPRIM)
+6 SET (END,X)=+$GET(^PRCP(445.3,"ANXT",PRCPPRIM))
+7 FOR
SET X=X+1
if X=END
QUIT
if X>999999
SET X=1
if '$DATA(^PRCP(445.3,"B",X))
QUIT
Begin DoDot:1
+8 KILL FLAG
SET Z=0
FOR
SET Z=$ORDER(^PRCP(445.3,"B",X,Z))
if 'Z
QUIT
IF $DATA(^PRCP(445.3,"AC",PRCPPRIM,Z))
SET FLAG=1
QUIT
End DoDot:1
if '$GET(FLAG)
QUIT
+9 SET ^PRCP(445.3,"ANXT",PRCPPRIM)=X
+10 LOCK -^PRCP(445.3,"ANXT",PRCPPRIM)
+11 IF X=END
WRITE !!?10,"YOU NEED TO DELETE SOME OF THE OLD ORDERS FIRST!"
KILL X
+12 QUIT
+13 ;
+14 ;
ORDERSEL(PRCPPRIM,PRCPSECO,PRCPSTAT,ADDNEW) ; select distribution order
+1 ; prcpprim=primary inventory point screen
+2 ; prcpseco=secondary inventory point screen
+3 ; prcpstat=status for screen (set to * to eliminate screen on status)
+4 ; addnew=1 to add new orders
+5 ; returns selected distribution order da number
+6 ; returns variable prcpfnew if its a newly created order
+7 NEW %,%H,%I,C,D0,DA,DG,DI,DQ,DIC,DIE,DLAYGO,DR,ORDERDA,PRCPNEW,PRCPPRIV,SCREEN,STATUS,X,Y
+8 KILL PRCPFNEW
+9 SET DIC(0)="AEQM"
SET DIC="^PRCP(445.3,"
+10 SET DIC("A")="Select DISTRIBUTION ORDER: "
+11 SET PRCPPRIV=1
+12 ;
+13 ; set up screen
+14 IF PRCPPRIM
SET DIC("S")="I $P(^(0),U,2)="_PRCPPRIM
+15 IF PRCPSECO
SET DIC("S")=$SELECT($GET(DIC("S"))="":"I ",1:DIC("S")_",")_"$P(^(0),U,3)="_PRCPSECO
+16 IF PRCPSTAT'="*"
Begin DoDot:1
+17 SET DIC("S")=DIC("S")_" S %=$P(^(0),U,6)"
+18 IF PRCPSTAT=""
SET DIC("S")=DIC("S")_" I %="""""
QUIT
+19 SET SCREEN=""
+20 FOR %=1:1
SET STATUS=$PIECE(PRCPSTAT,"!",%)
if STATUS=""
QUIT
SET SCREEN=SCREEN_$SELECT(SCREEN="":"",1:"!")_"(%="_$CHAR(34)_STATUS_$CHAR(34)_")"
+21 SET DIC("S")=DIC("S")_" I "_SCREEN
End DoDot:1
+22 ;
+23 ; adding new entries allowed
+24 IF ADDNEW
SET DIC(0)="AEQML"
SET DLAYGO=445.3
SET DIC("DR")="1////"_PRCPPRIM_$SELECT(PRCPSECO:";2////"_PRCPSECO,1:"")
+25 ;
+26 DO ^DIC
IF Y'>0
QUIT 0
+27 SET ORDERDA=+Y
+28 IF $PIECE(Y,"^",3)
SET PRCPFNEW=1
+29 IF $GET(PRCPFNEW)
SET $PIECE(^PRCP(445.3,ORDERDA,0),"^",4,5)=DT_"^"_DUZ
SET $PIECE(^(0),"^",8)="R"
+30 QUIT ORDERDA
+31 ;
+32 ;
TYPE(ORDERDA) ; ask order type for orderda
+1 ; returns 1 if unsuccessful
+2 IF '$DATA(^PRCP(445.3,+ORDERDA,0))
QUIT 1
+3 IF $PIECE(^PRCP(445.3,+ORDERDA,0),"^",6)="P"
QUIT 0
+4 NEW %,D,D0,DA,DDH,DI,DIC,DIE,DIR,DQ,DR,DZ,ORD,PRCPEXIT,PRCPPRIV,PRCPSEC,X,Y
+5 ; if this is a regular order for a supply station secondary, don't prompt
+6 ; if this is an emergency or call-in order for a supply station secondary, allow all selections but regular.
+7 SET ORD=0
SET PRCPEXIT=0
+8 SET PRCPSEC=$PIECE($GET(^PRCP(445.3,ORDERDA,0)),"^",3)
+9 IF $PIECE($GET(^PRCP(445,PRCPSEC,5)),"^",1)]""
IF $DATA(^PRCP(445.3,ORDERDA,1))
Begin DoDot:1
+10 SET ORD=$PIECE($GET(^PRCP(445.3,ORDERDA,0)),"^",8)
+11 IF ORD="R"
Begin DoDot:2
+12 DO EN^DDIOL("This is a regular order on a supply station secondary.")
+13 DO EN^DDIOL("Its 'TYPE OF ORDER' cannot be edited to CALL_IN or EMERGENCY.")
+14 SET PRCPEXIT=1
End DoDot:2
QUIT
+15 SET DIR("A")="TYPE OF ORDER"
+16 SET DIR("A",1)="This order is for a supply station secondary."
+17 SET DIR("A",2)="The order type cannot be changed to regular."
+18 SET DIR(0)="SB^C:CALL-IN;E:EMERGENCY"
+19 SET DIR("B")="CALL-IN"
IF ORD="E"
SET DIR("B")="EMERGENCY"
+20 DO ^DIR
+21 IF $DATA(DUOUT)!$DATA(DTOUT)
SET PRCPEXIT=1
QUIT
+22 SET ORD=0
IF Y="E"!(Y="C")
SET ORD=Y
End DoDot:1
if PRCPEXIT
GOTO TYPEQ
+23 SET (DIE,DIC)="^PRCP(445.3,"
SET DA=ORDERDA
SET DR="3.5"
+24 IF ORD'=0
SET DR=DR_"///^S X=ORD"
+25 SET PRCPPRIV=1
DO ^DIE
+26 IF $DATA(Y)
QUIT 1
TYPEQ QUIT 0
+1 ;
+2 ;
+1 ; returns 1 if unsuccessful
+2 IF '$DATA(^PRCP(445.3,+ORDERDA,0))
QUIT 1
+3 IF $PIECE(^PRCP(445.3,+ORDERDA,0),"^",6)="P"
QUIT 0
+4 NEW %,D,D0,DA,DDH,DI,DIC,DIE,DQ,DR,DZ,PRCPPRIV,X,Y
+5 SET (DIE,DIC)="^PRCP(445.3,"
SET DA=ORDERDA
SET DR="8"
SET PRCPPRIV=1
DO ^DIE
+6 IF $DATA(Y)
QUIT 1
+7 QUIT 0
+8 ;
+9 ;
ITEMSEL(ORDERDA,PRCPPRIM,PRCPADD) ; select item from distribution order
+1 ; returns item number selected
+2 NEW %,C,DA,DDC,DG,DIC,DLAYGO,I,PRCPSET,X,Y
+3 IF '$DATA(^PRCP(445.3,ORDERDA,0))
QUIT 0
+4 if '$DATA(^PRCP(445.3,ORDERDA,1,0))
SET ^(0)="^445.37PI^^"
+5 SET DIC="^PRCP(445.3,"_ORDERDA_",1,"
SET DIC(0)="QEAMZO"
+6 IF PRCPADD
SET DIC(0)="QEALMZO"
+7 SET (PRCPSET,DIC("S"))="I $D(^PRCP(445,PRCPPRIM,1,+Y,0))"
+8 ; if this is a regular order for a supply station secondary, restrict
+9 ; item selection to items stocked in the supply station (i.e. items
+10 ; with non-zero normal levels)
+11 IF PRCPADD
IF $PIECE($GET(^PRCP(445,$PIECE(^PRCP(445.3,ORDERDA,0),"^",3),5)),"^",1)]""
IF $PIECE(^PRCP(445.3,ORDERDA,0),"^",8)="R"
Begin DoDot:1
+12 SET PRCPSEC=$PIECE(^PRCP(445.3,ORDERDA,0),"^",3)
+13 SET U="^"
+14 SET (PRCPSET,DIC("S"))=PRCPSET_",$D(^PRCP(445,PRCPSEC,1,+Y,0)),$P(^PRCP(445,PRCPSEC,1,+Y,0),U,9)>0"
End DoDot:1
+15 SET DA(1)=ORDERDA
+16 SET DLAYGO=445.3
+17 WRITE !
DO ^DIC
+18 QUIT $SELECT(+Y>0:+Y,1:0)
+19 ;
+20 ;
ITEMEDIT(ORDERDA,ITEMDA,ASKCOST) ; edit item on distribution order
+1 NEW D,D0,DA,DI,DIC,DIE,DQ,DR,X,Y
+2 IF '$DATA(^PRCP(445.3,ORDERDA,1,ITEMDA,0))
QUIT
+3 SET (DIC,DIE)="^PRCP(445.3,"_ORDERDA_",1,"
SET DA(1)=ORDERDA
SET DA=ITEMDA
SET DR="1;"_$SELECT(ASKCOST:"2;",1:"")
DO ^DIE
+4 QUIT
+5 ;
+6 ;
ITEMADD(ORDERDA,ITEMDA,QTY) ; automatically add items to distribution order
+1 ; return item number added or 0 if unsuccessful
+2 NEW %,D0,DA,DD,DI,DIC,DIE,DLAYGO,DQ,DR,PRCPPRIM,PRCPPRIV,UNITCOST,X,Y
+3 IF '$DATA(^PRCP(445.3,ORDERDA))
QUIT 0
+4 IF 'ITEMDA
QUIT 0
+5 SET PRCPPRIM=+$PIECE($GET(^PRCP(445.3,ORDERDA,0)),"^",2)
SET UNITCOST=+$PIECE($GET(^PRCP(445,PRCPPRIM,1,ITEMDA,0)),"^",22)
+6 IF 'PRCPPRIM
IF 'QTY
QUIT 0
+7 IF '$DATA(^PRCP(445.3,ORDERDA,1,0))
SET ^(0)="^445.37PI^^"
+8 SET DIC("DR")="1///"_QTY_";2///"_UNITCOST
+9 SET DIC="^PRCP(445.3,"_ORDERDA_",1,"
SET DA(1)=ORDERDA
SET DIC(0)="LZ"
SET DLAYGO=445.3
SET (DINUM,X)=ITEMDA
SET PRCPPRIV=1
DO FILE^DICN
+10 IF Y<0
QUIT 0
+11 QUIT +Y
