PRCFAC0 ;WISC@ALTOONA/CTB-ROUTINE TO PROCESS OBLIGATIONS ;11/4/92 4:32 PM
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
D ^PRCFSITE G:'% OUT3^PRCFAC01
K DIC("A") S D="C",DIC("S")="I $D(^(7)),+^(0)=PRC(""SITE""),$D(^PRCD(442.3,+^(7),0)) S FSO=$P(^(0),U,3) I FSO>9,FSO<21",DIC("A")="Select Purchase Order Number: ",DIC=442,DIC(0)="AEQZ" D IX^DIC K DIC("S"),DIC("A"),FSO G:+Y<0 OUT3^PRCFAC01
S PO(0)=Y(0),PO=Y,PRCFA("PODA")=+Y,PCP=+$P(PO(0),"^",3),$P(PCP,"^",2)=$S($D(^PRC(420,PRC("SITE"),1,+PCP,0)):$P(^(0),"^",12),1:"")
I +$P(PO(0),U,3)=0!('$D(^PRC(420,PRC("SITE"),1,+PCP,0))) W $C(7),"PURCHASE ORDER DOES NOT CONTAIN A CONTROL POINT.",!,"UNABLE TO PROCESS, PLEASE RETURN TO SUPPLY FOR CORRECTION!" G OUT3^PRCFAC01
I $P(PO(0),U,5)="",$P(PCP,"^",2)<2 F II=0:0 D CCEDIT Q:$P(PO(0),"^",5)]"" G:'% OUT3^PRCFAC01
I +$P(PO(0),"^",16)=0 D NC G OUT3^PRCFAC01:%<0,NC^PRCFAC01:%=2
I $P(PO(0),U,6)="",+$P(PO(0),U,7)'=0,$P(PCP,"^",2)="" F II=0:0 W !!,"No BOC data has been recorded for this Purchase Order.",$C(7) D SAEDIT Q:($P(PO(0),"^",6)]""&(+$P(PO(0),"^",7)=0)) Q:%<0
SC ;PAINT SCREEN
I '$D(IOF)!('$D(IOM)) S IOP="HOME" D ^%ZIS K POP
K II W @IOF,!?(IOM-37\2),"PURCHASE ORDER - "_$P(PO(0),"^"),!!," COST CENTER: "_$P(PO(0),"^",5),?IOM\2-4,"CONTROL POINT: "_$P(PO(0),"^",3)
W !!,"BOC #1: "_$P(PO(0),"^",6),?IOM\2,"AMOUNT #1: $ "_$J($P(PO(0),"^",7),0,2),!!
I $P(PO(0),"^",8)]"",$P(PO(0),"^",9)]"" W "BOC #2: "_$P(PO(0),"^",8),?IOM\2,"AMOUNT #2: $ "_$J($P(PO(0),"^",9),0,2),!!
D:$D(^PRC(442,PRCFA("PODA"),13)) ^PRCFAC0J
S %A="The information listed above is recorded on this Purchase order.",%A(1)="Is this information correct",%B="Entering a 'NO' will allow you to edit the Cost Center and BOCs.",%B(1)="An '^' will terminate the option.",%=1
D ^PRCFYN G OUT3^PRCFAC01:%<1 I %=2 D:$P(PCP,"^",2)<2 CCEDIT G:'% OUT3^PRCFAC01 D:$P(PCP,"^",2)="" SAEDIT G SC
S Z=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_$P($P(PO(0),"^",3)," "),C1=1
G ^PRCFAC01
ONEITEM S DIC("A")="Select ITEM: ",DA=PRCFA("PODA"),DIC="^PRC(442,"_DA_",2,",DIC(0)="AEQMZ" D ^DIC K DIC("A") I Y<0 S:X["^" PRCFOUT="" D ^PRCHS S PO(0)=^PRC(442,PRCFA("PODA"),0) S %=$S($D(PRCFOUT):-1,1:1) Q
S DA=+Y,DIE=DIC,DR=3.5 D ^DIE S DIC("A")="Select Next ITEM: " G ONEITEM
ALLITEMS S DIC=420.2,DIC(0)="AQEMNZ" D ^DIC Q:Y<0 S SA=+Y
I $P(PO(0),"^",5)="" W !,"You're missing a Cost Center. Let's start over." G OUT3^PRCFAC01
S SA=Y(0) I '$D(^PRCD(420.1,$P(PO(0),"^",5),1,+SA)) W $C(7) S %A="BOC "_+SA_" is not valid with Cost Center "_$P(PO(0),"^",5)_". OK to continue",%B="",%=2 D ^PRCFYN I %'=1 S %=-1 Q
S %A="I will now enter BOC "_+SA_", on all items. Is this OK",%B="",%=2 D ^PRCFYN Q:%'=1
S DA=0 F I=1:1 S DA=$O(^PRC(442,+PO,2,DA)) Q:'DA S:$D(^(DA,0)) $P(^(0),"^",4)=$P(SA,"^")
K SA S DA=PRCFA("PODA") D ^PRCHS S PO(0)=^PRC(442,PRCFA("PODA"),0) Q
SAEDIT S %A="Do you wish to assign the same BOC to ALL items",%B="",%=2 D ^PRCFYN G ALLITEMS:%=1,ONEITEM:%=2 Q
CCEDIT S DA=PRCFA("PODA"),DR="2;",DIE="^PRC(442," D ^DIE S %=1 I $D(Y) S %=0 Q
S PO(0)=^PRC(442,DA,0) Q
NC S %A="This order appears to be a 'NO CHARGE' order. Do you need to take",%A(1)="any action on this order",%B="'No' will mark the order appropriately and return it to supply."
S %B(1)="'Yes' will allow you to continue and create a code sheet.",%B(2)="'^' to exit.",%=2 D ^PRCFYN Q:%'=2
D SIG^PRCFACX0 I $D(PRCFA("SIGFAIL")) K PRCFA("SIGFAIL") S %=-1 Q
S %=2 Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFAC0 3487 printed Dec 13, 2024@02:01:47 Page 2
PRCFAC0 ;WISC@ALTOONA/CTB-ROUTINE TO PROCESS OBLIGATIONS ;11/4/92 4:32 PM
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 DO ^PRCFSITE
if '%
GOTO OUT3^PRCFAC01
+3 KILL DIC("A")
SET D="C"
SET DIC("S")="I $D(^(7)),+^(0)=PRC(""SITE""),$D(^PRCD(442.3,+^(7),0)) S FSO=$P(^(0),U,3) I FSO>9,FSO<21"
SET DIC("A")="Select Purchase Order Number: "
SET DIC=442
SET DIC(0)="AEQZ"
DO IX^DIC
KILL DIC("S"),DIC("A"),FSO
if +Y<0
GOTO OUT3^PRCFAC01
+4 SET PO(0)=Y(0)
SET PO=Y
SET PRCFA("PODA")=+Y
SET PCP=+$PIECE(PO(0),"^",3)
SET $PIECE(PCP,"^",2)=$SELECT($DATA(^PRC(420,PRC("SITE"),1,+PCP,0)):$PIECE(^(0),"^",12),1:"")
+5 IF +$PIECE(PO(0),U,3)=0!('$DATA(^PRC(420,PRC("SITE"),1,+PCP,0)))
WRITE $CHAR(7),"PURCHASE ORDER DOES NOT CONTAIN A CONTROL POINT.",!,"UNABLE TO PROCESS, PLEASE RETURN TO SUPPLY FOR CORRECTION!"
GOTO OUT3^PRCFAC01
+6 IF $PIECE(PO(0),U,5)=""
IF $PIECE(PCP,"^",2)<2
FOR II=0:0
DO CCEDIT
if $PIECE(PO(0),"^",5)]""
QUIT
if '%
GOTO OUT3^PRCFAC01
+7 IF +$PIECE(PO(0),"^",16)=0
DO NC
if %<0
GOTO OUT3^PRCFAC01
if %=2
GOTO NC^PRCFAC01
+8 IF $PIECE(PO(0),U,6)=""
IF +$PIECE(PO(0),U,7)'=0
IF $PIECE(PCP,"^",2)=""
FOR II=0:0
WRITE !!,"No BOC data has been recorded for this Purchase Order.",$CHAR(7)
DO SAEDIT
if ($PIECE(PO(0),"^",6)]""&(+$PIECE(PO(0),"^",7)=0))
QUIT
if %<0
QUIT
SC ;PAINT SCREEN
+1 IF '$DATA(IOF)!('$DATA(IOM))
SET IOP="HOME"
DO ^%ZIS
KILL POP
+2 KILL II
WRITE @IOF,!?(IOM-37\2),"PURCHASE ORDER - "_$PIECE(PO(0),"^"),!!," COST CENTER: "_$PIECE(PO(0),"^",5),?IOM\2-4,"CONTROL POINT: "_$PIECE(PO(0),"^",3)
+3 WRITE !!,"BOC #1: "_$PIECE(PO(0),"^",6),?IOM\2,"AMOUNT #1: $ "_$JUSTIFY($PIECE(PO(0),"^",7),0,2),!!
+4 IF $PIECE(PO(0),"^",8)]""
IF $PIECE(PO(0),"^",9)]""
WRITE "BOC #2: "_$PIECE(PO(0),"^",8),?IOM\2,"AMOUNT #2: $ "_$JUSTIFY($PIECE(PO(0),"^",9),0,2),!!
+5 if $DATA(^PRC(442,PRCFA("PODA"),13))
DO ^PRCFAC0J
+6 SET %A="The information listed above is recorded on this Purchase order."
SET %A(1)="Is this information correct"
SET %B="Entering a 'NO' will allow you to edit the Cost Center and BOCs."
SET %B(1)="An '^' will terminate the option."
SET %=1
+7 DO ^PRCFYN
if %<1
GOTO OUT3^PRCFAC01
IF %=2
if $PIECE(PCP,"^",2)<2
DO CCEDIT
if '%
GOTO OUT3^PRCFAC01
if $PIECE(PCP,"^",2)=""
DO SAEDIT
GOTO SC
+8 SET Z=PRC("SITE")_"-"_PRC("FY")_"-"_PRC("QTR")_"-"_$PIECE($PIECE(PO(0),"^",3)," ")
SET C1=1
+9 GOTO ^PRCFAC01
ONEITEM SET DIC("A")="Select ITEM: "
SET DA=PRCFA("PODA")
SET DIC="^PRC(442,"_DA_",2,"
SET DIC(0)="AEQMZ"
DO ^DIC
KILL DIC("A")
IF Y<0
if X["^"
SET PRCFOUT=""
DO ^PRCHS
SET PO(0)=^PRC(442,PRCFA("PODA"),0)
SET %=$SELECT($DATA(PRCFOUT):-1,1:1)
QUIT
+1 SET DA=+Y
SET DIE=DIC
SET DR=3.5
DO ^DIE
SET DIC("A")="Select Next ITEM: "
GOTO ONEITEM
ALLITEMS SET DIC=420.2
SET DIC(0)="AQEMNZ"
DO ^DIC
if Y<0
QUIT
SET SA=+Y
+1 IF $PIECE(PO(0),"^",5)=""
WRITE !,"You're missing a Cost Center. Let's start over."
GOTO OUT3^PRCFAC01
+2 SET SA=Y(0)
IF '$DATA(^PRCD(420.1,$PIECE(PO(0),"^",5),1,+SA))
WRITE $CHAR(7)
SET %A="BOC "_+SA_" is not valid with Cost Center "_$PIECE(PO(0),"^",5)_". OK to continue"
SET %B=""
SET %=2
DO ^PRCFYN
IF %'=1
SET %=-1
QUIT
+3 SET %A="I will now enter BOC "_+SA_", on all items. Is this OK"
SET %B=""
SET %=2
DO ^PRCFYN
if %'=1
QUIT
+4 SET DA=0
FOR I=1:1
SET DA=$ORDER(^PRC(442,+PO,2,DA))
if 'DA
QUIT
if $DATA(^(DA,0))
SET $PIECE(^(0),"^",4)=$PIECE(SA,"^")
+5 KILL SA
SET DA=PRCFA("PODA")
DO ^PRCHS
SET PO(0)=^PRC(442,PRCFA("PODA"),0)
QUIT
SAEDIT SET %A="Do you wish to assign the same BOC to ALL items"
SET %B=""
SET %=2
DO ^PRCFYN
if %=1
GOTO ALLITEMS
if %=2
GOTO ONEITEM
QUIT
CCEDIT SET DA=PRCFA("PODA")
SET DR="2;"
SET DIE="^PRC(442,"
DO ^DIE
SET %=1
IF $DATA(Y)
SET %=0
QUIT
+1 SET PO(0)=^PRC(442,DA,0)
QUIT
NC SET %A="This order appears to be a 'NO CHARGE' order. Do you need to take"
SET %A(1)="any action on this order"
SET %B="'No' will mark the order appropriately and return it to supply."
+1 SET %B(1)="'Yes' will allow you to continue and create a code sheet."
SET %B(2)="'^' to exit."
SET %=2
DO ^PRCFYN
if %'=2
QUIT
+2 DO SIG^PRCFACX0
IF $DATA(PRCFA("SIGFAIL"))
KILL PRCFA("SIGFAIL")
SET %=-1
QUIT
+3 SET %=2
QUIT
