Routine: PRCPOPUS

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.

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

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

REMARKS(ORDERDA) ;  ask remarks 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,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

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  Apr 23, 2025@18:28:54                                                                                                                                                                                                    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       ;

REMARKS(ORDERDA) ;  ask remarks 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,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

PRCPOPUS.m