PRCHNRQ ;ID/RSD-ENTER/EDIT REQUISITIONS ;3/10/98 11:43 AM
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
N POCARD
I $P($G(^PRC(442,PRCHPO,0)),U,2)=25 S POCARD=1
S PRCHN("PO")=$P($P(^PRC(442,PRCHPO,0),"-",2),U,1),PRCHLCNT=$P(^(0),U,14),Y=$G(^PRC(440,PRCHV,2)),PRCHN("LSA")=$P(Y,U,5),PRCHN("MB")=$S(PRCHDT:$P(Y,U,3),1:$P(Y,U,6))
S PRCHN("SFC")=$P(^PRC(442,PRCHPO,0),U,19)
S X="",PRCHN("ID")=PRCHN("PO") F I=1:1 S X=$E(PRCHN("PO"),I) Q:X="" I X=+X S PRCHN("ID")=$E(PRCHN("PO"),1,I-1)_$E(PRCHN("PO"),I+1,6) Q
I 'PRCHN("MP") W !?5,"Method of Processing is undefined !",$C(7) G INC
K ^PRC(442,PRCHPO,9) S $P(^PRC(442,PRCHPO,0),U,15,16)="0^0"
I '$G(PRCHPC),'$G(PRCHDELV),PRCHDT D FPDS^PRCHFPD2
;
EST G INC:'$D(PRCHPO) I 'PRCHEST,PRCHESTL S $P(^PRC(442,PRCHPO,0),U,18)=""
I PRCHEST D EST^PRCHNPO6
S PRCHTYP="A" S:$D(PRCHISMS) PRCHTYP="I" K PRCHNM
D EN2A^PRCHNPO7
;
; FIX FOR NOIS SDH-1196-N0212
;
S (D0,DA)=PRCHPO
D ^PRCHSF
;
; END OF FIX
;
S (X,Y)=4,DA=PRCHPO D UPD^PRCHSTAT S %=1,%B="",%A=" Review Requisition " D ^PRCFYN G:%=-1 INC I %=1 S D0=PRCHPO D ^PRCHDP1
S VAR2="" I $G(PRCHPC)'=1 D NEW^PRCOEDC(PRCHPO,.VAR2) I $G(VAR2)]"" W !,VAR2 K VAR2 G INC
I $G(POCARD)=1 S FILE=442 D LIMIT^PRCHCD0 I $G(ERROR) K FILE,ERROR G INC
G:$$ISMSFLAG^PRCPUX2(PRC("SITE"))=2 SIG
I '$D(PRCHLOG) G SIG ; LOG BYPASS SWITCH
K PRCHNM G:PRCHSC=9 SIG I $D(^PRC(442,PRCHPO,18)),$P(^(18),U,6)]"" W !!,$C(7),"LOG code sheets have already been created.",!! G SIG
I $D(^PRC(442,PRCHPO,1)),$P(^(1),U,18)="N" D W2 G SIG
I $G(POCARD) G SIG
W !!!! S %B="",%A=" Create LOG code sheets ",%=2 D ^PRCFYN G:%=-1 INC G:%'=1 SIG
S PRCHENT="PRCHNRQ" D EN11^PRCHEC G:'$D(PRCHPO) INC
;
SIG I PRCHSC'=9,$D(PRCHLOG) D:'$D(^PRC(442,PRCHPO,18)) W I $D(^PRC(442,PRCHPO,18)),$P(^(18),U,6)']"",'$G(POCARD) D W
I '$G(POCARD),$D(PRCHISMS),(PRCHSC=9!(PRCHSC=1)) I $P($G(^PRC(442,PRCHPO,12)),"^",10)="" D G:%=1 ISMS G INC
.W !! S %A=" Do you want to send code sheet to Austin? " S %=2 D ^PRCFYN Q
W !! S %A=" Affix signature to Requisition and Print ",%B="If you answer 'Y' (YES), you can no longer edit this Order except by Amendment.",%B(1)="You must answer YES before you can receive items on this Order."
S %=2 D ^PRCFYN G:%'=1 INC
I '$D(PRCHNM) S DA=PRCHPO,P=+PRC("PER") S PRCSIG="" D ESIG^PRCUESIG(DUZ,.PRCSIG) S ROUTINE="PRCUESIG" I PRCSIG<1 D QQ G INC
;
PRT ;SET STATUS TO 'ORDERED (NO FISCAL ACTION REQUIRED' IF SUPPLY FUND, 'PENDING FISCAL ACTION' OTHERWISE
S FILE=442 D:$D(PRCHPO) CHECK^PRCHSWCH K FILE
S (PRCHSTAT,X)=$S(PRCHN("SFC")=2!$G(POCARD)!$G(PRCHOBL)=1:22,1:10),DA=PRCHPO D ENS^PRCHSTAT
S (D0,DA)=PRCHPO D ^PRCHSF
S PRCSIG="" D ENCODE^PRCHES5(PRCHPO,DUZ,.PRCSIG) S ROUTINE=$T(+0) I PRCSIG<1 D QQ G Q
I $G(PRCHPC)!$G(PRCHDELV) D
. I $P($G(^PRC(442,PRCHPO,23)),U,8)]"" D
. . S PRCHCD=$P(^PRC(442,PRCHPO,23),U,8)
. . S PRCHPOMT=$P(^PRC(442,PRCHPO,0),U,15)
. . S $P(^(2),U)=+$P($G(^PRC(440.5,PRCHCD,2)),U)+PRCHPOMT
. S PODA=DA,DA=CDA S X=$P(^PRC(442,PRCHPO,0),U,15) D ESIG^PRCH410 S DA=PODA K PODA
I PRCHN("MP")=25 D S $P(^PRC(442,PRCHPO,24),U)=1 G INV
. I $G(PRCHPC)'=1 N PRCOPODA S PRCOPODA=PRCHPO W !!,"...now generating the PHA transaction" D ^PRCOEDI
. I '$P($G(^PRC(442,PRCHPO,23)),U,11) D
. . I '$P(^PRC(442,PRCHPO,0),U,12) S DA=PRCHPO D START^PRCH410 D Q
. . . S PODA=PRCHPO,DA=CDA S X=$P(^PRC(442,PRCHPO,0),U,15) D ESIG^PRCH410 S DA=PODA K PODA
. . . ;Update file #440.5
. . . S PRCHCD=+$P(^PRC(442,PRCHPO,23),U,8)
. . . S PRCHPOMT=$P(^PRC(442,PRCHPO,0),U,15)
. . . S $P(^PRC(440.5,PRCHCD,2),U,1)=$P(^PRC(440.5,PRCHCD,2),U,1)+PRCHPOMT
. . I $P(^PRC(442,PRCHPO,0),U,12) D COMM^PRCSPC(PRCHPO,$P(^PRC(442,PRCHPO,0),U,10))
;
I $G(PRCHSTAT)'="",PRCHSTAT'=10 D S:$P(^PRC(442,PRCHPO,0),U,2)=26 $P(^PRC(442,PRCHPO,24),U)=1 G INV
. N PRCOPODA S PRCOPODA=PRCHPO D ^PRCOEDI,SUPP^PRCFFMO
I $G(PRCHOBL)=2 N PRCOPODA S PRCOPODA=PRCHPO W !!,"...now generating the PHA transaction" D ^PRCOEDI
;S PRCOPODA=PRCHPO I PRCHN("SFC")=2!$G(POCARD) D
;. D:'$G(POCARD) OBL D:$G(PRCHPC)'=1 ^PRCOEDI
;. I $G(POCARD)&($P(^PRC(442,PRCHPO,0),U,12)]"") D
;. . D COMM^PRCSPC(PRCHPO,$P(^PRC(442,PRCHPO,0),U,10)) Q
;. I $G(PRCHN("SFC"))=2 D SUPP^PRCFFMO W VAR2 H 2
INV S DA=PRCHPO D UPDATE^PRCPWIU
;I $G(PRCH("SFC"))'=2,'$G(POCARD) D
;. I $G(PRCHOBL)=1 D:$G(PRCHPC)'=1 ^PRCOEDI D SUPP^PRCFFMO W VAR2 H 2
;. I $G(PRCHOBL)=2 D:$G(PRCHPC)'=1 ^PRCOEDI
I $D(PRCHNRQ) S:PRCHNRQ="" PRCHNRQ=1
I '$G(POCARD) S PRCHQ("DEST")="F",D0=PRCHPO,PRCHQ="^PRCHFPNT" D ^PRCHQUE
I $G(PRCHN("SFC"))=2!$G(POCARD) S:'$G(POCARD) PRCHQ("DEST")="S" S D0=PRCHPO,PRCHQ="^PRCHFPNT" D ^PRCHQUE
G Q
;
QQ S:'$D(ROUTINE) ROUTINE=$T(+0) W !!,$$ERR^PRCHQQ(ROUTINE,PRCSIG) W:PRCSIG=0!(PRCSIG=-3) !,"Notify Application Coordinator!",$C(7) S DIR(0)="EAO",DIR("A")="Press <return> to continue" D ^DIR K PRCSIG,ROUTINE
Q
;
Q L D Q^PRCHNPO4 K PRCF,PRCFA,PRCHENT,PRCHLOG,PRCHN,PRCHTYP,ROUTINE
Q
;
ISMS ;CHECK ISMS SWITCH AND CREATE ISMS COD
I $$ISMSFLAG^PRCPUX2(PRC("SITE"))=2 S PRCHTRAN="" D
.I PRCHSC=1 S PRCHTRAN=$S($P(^PRC(442,PRCHPO,0),U,19)=2:"TO1",1:"SO1") D EN11^PRCHEI(PRCHTRAN)
.I PRCHSC=9 S PRCHTRAN="PO1" D EN11^PRCHEI(PRCHTRAN)
G Q
;
INC D Q G ERR^PRCHNPO
;
OBL ;UPDATE CONTROL POINT OBLIGATED BALANCE
I $D(^PRC(442,PRCHPO,18)),$P(^(18),U,12) W $C(7),!,"This Supply Fund order has already updated the Control Point",!,"Obligated Balance.",!! Q
I $D(PRCHN("SFC")),PRCHN("SFC")=2 S $P(^PRC(442,PRCHPO,18),U,12)=1
S DA=+$P(^PRC(442,PRCHPO,0),U,12) G:'DA ERR G:'$D(^PRCS(410,DA,0)) ERR
I $D(PRC("PER")) S PRCSIG="" D ENCODE^PRCSC2(DA,DUZ,.PRCSIG) S ROUTINE=$T(+0) I PRCSIG<1 D QQ G Q
S X=$P(^PRCS(410,DA,4),"^",8) D TRANK^PRCSES
S X=$P(^PRC(442,PRCHPO,0),U,16),Y=$P(^(0),U,10),$P(^PRCS(410,DA,4),"^",4)=DT,$P(^(9),"^",2)=Y,$P(^(4),"^",3)=X,$P(^(4),"^",8)=X D TRANS^PRCSES,TRANS1^PRCSES
Q
;
ERR W $C(7),!!,"Control Point Balances NOT updated!!"
Q
;
W Q:'$D(PRCHLOG) W $C(7),!!,"WARNING--LOG code sheets have NOT been created!!"
Q
;
W2 W !!,$C(7),"LOG code sheets for non-expendable good not yet programmed.",!,"Use FALCON or KEYPUNCH A CODESHEET option to create these.",!!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHNRQ 6252 printed Apr 09, 2024@21:10:06 Page 2
PRCHNRQ ;ID/RSD-ENTER/EDIT REQUISITIONS ;3/10/98 11:43 AM
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 NEW POCARD
+3 IF $PIECE($GET(^PRC(442,PRCHPO,0)),U,2)=25
SET POCARD=1
+4 SET PRCHN("PO")=$PIECE($PIECE(^PRC(442,PRCHPO,0),"-",2),U,1)
SET PRCHLCNT=$PIECE(^(0),U,14)
SET Y=$GET(^PRC(440,PRCHV,2))
SET PRCHN("LSA")=$PIECE(Y,U,5)
SET PRCHN("MB")=$SELECT(PRCHDT:$PIECE(Y,U,3),1:$PIECE(Y,U,6))
+5 SET PRCHN("SFC")=$PIECE(^PRC(442,PRCHPO,0),U,19)
+6 SET X=""
SET PRCHN("ID")=PRCHN("PO")
FOR I=1:1
SET X=$EXTRACT(PRCHN("PO"),I)
if X=""
QUIT
IF X=+X
SET PRCHN("ID")=$EXTRACT(PRCHN("PO"),1,I-1)_$EXTRACT(PRCHN("PO"),I+1,6)
QUIT
+7 IF 'PRCHN("MP")
WRITE !?5,"Method of Processing is undefined !",$CHAR(7)
GOTO INC
+8 KILL ^PRC(442,PRCHPO,9)
SET $PIECE(^PRC(442,PRCHPO,0),U,15,16)="0^0"
+9 IF '$GET(PRCHPC)
IF '$GET(PRCHDELV)
IF PRCHDT
DO FPDS^PRCHFPD2
+10 ;
EST if '$DATA(PRCHPO)
GOTO INC
IF 'PRCHEST
IF PRCHESTL
SET $PIECE(^PRC(442,PRCHPO,0),U,18)=""
+1 IF PRCHEST
DO EST^PRCHNPO6
+2 SET PRCHTYP="A"
if $DATA(PRCHISMS)
SET PRCHTYP="I"
KILL PRCHNM
+3 DO EN2A^PRCHNPO7
+4 ;
+5 ; FIX FOR NOIS SDH-1196-N0212
+6 ;
+7 SET (D0,DA)=PRCHPO
+8 DO ^PRCHSF
+9 ;
+10 ; END OF FIX
+11 ;
+12 SET (X,Y)=4
SET DA=PRCHPO
DO UPD^PRCHSTAT
SET %=1
SET %B=""
SET %A=" Review Requisition "
DO ^PRCFYN
if %=-1
GOTO INC
IF %=1
SET D0=PRCHPO
DO ^PRCHDP1
+13 SET VAR2=""
IF $GET(PRCHPC)'=1
DO NEW^PRCOEDC(PRCHPO,.VAR2)
IF $GET(VAR2)]""
WRITE !,VAR2
KILL VAR2
GOTO INC
+14 IF $GET(POCARD)=1
SET FILE=442
DO LIMIT^PRCHCD0
IF $GET(ERROR)
KILL FILE,ERROR
GOTO INC
+15 if $$ISMSFLAG^PRCPUX2(PRC("SITE"))=2
GOTO SIG
+16 ; LOG BYPASS SWITCH
IF '$DATA(PRCHLOG)
GOTO SIG
+17 KILL PRCHNM
if PRCHSC=9
GOTO SIG
IF $DATA(^PRC(442,PRCHPO,18))
IF $PIECE(^(18),U,6)]""
WRITE !!,$CHAR(7),"LOG code sheets have already been created.",!!
GOTO SIG
+18 IF $DATA(^PRC(442,PRCHPO,1))
IF $PIECE(^(1),U,18)="N"
DO W2
GOTO SIG
+19 IF $GET(POCARD)
GOTO SIG
+20 WRITE !!!!
SET %B=""
SET %A=" Create LOG code sheets "
SET %=2
DO ^PRCFYN
if %=-1
GOTO INC
if %'=1
GOTO SIG
+21 SET PRCHENT="PRCHNRQ"
DO EN11^PRCHEC
if '$DATA(PRCHPO)
GOTO INC
+22 ;
SIG IF PRCHSC'=9
IF $DATA(PRCHLOG)
if '$DATA(^PRC(442,PRCHPO,18))
DO W
IF $DATA(^PRC(442,PRCHPO,18))
IF $PIECE(^(18),U,6)']""
IF '$GET(POCARD)
DO W
+1 IF '$GET(POCARD)
IF $DATA(PRCHISMS)
IF (PRCHSC=9!(PRCHSC=1))
IF $PIECE($GET(^PRC(442,PRCHPO,12)),"^",10)=""
Begin DoDot:1
+2 WRITE !!
SET %A=" Do you want to send code sheet to Austin? "
SET %=2
DO ^PRCFYN
QUIT
End DoDot:1
if %=1
GOTO ISMS
GOTO INC
+3 WRITE !!
SET %A=" Affix signature to Requisition and Print "
SET %B="If you answer 'Y' (YES), you can no longer edit this Order except by Amendment."
SET %B(1)="You must answer YES before you can receive items on this Order."
+4 SET %=2
DO ^PRCFYN
if %'=1
GOTO INC
+5 IF '$DATA(PRCHNM)
SET DA=PRCHPO
SET P=+PRC("PER")
SET PRCSIG=""
DO ESIG^PRCUESIG(DUZ,.PRCSIG)
SET ROUTINE="PRCUESIG"
IF PRCSIG<1
DO QQ
GOTO INC
+6 ;
PRT ;SET STATUS TO 'ORDERED (NO FISCAL ACTION REQUIRED' IF SUPPLY FUND, 'PENDING FISCAL ACTION' OTHERWISE
+1 SET FILE=442
if $DATA(PRCHPO)
DO CHECK^PRCHSWCH
KILL FILE
+2 SET (PRCHSTAT,X)=$SELECT(PRCHN("SFC")=2!$GET(POCARD)!$GET(PRCHOBL)=1:22,1:10)
SET DA=PRCHPO
DO ENS^PRCHSTAT
+3 SET (D0,DA)=PRCHPO
DO ^PRCHSF
+4 SET PRCSIG=""
DO ENCODE^PRCHES5(PRCHPO,DUZ,.PRCSIG)
SET ROUTINE=$TEXT(+0)
IF PRCSIG<1
DO QQ
GOTO Q
+5 IF $GET(PRCHPC)!$GET(PRCHDELV)
Begin DoDot:1
+6 IF $PIECE($GET(^PRC(442,PRCHPO,23)),U,8)]""
Begin DoDot:2
+7 SET PRCHCD=$PIECE(^PRC(442,PRCHPO,23),U,8)
+8 SET PRCHPOMT=$PIECE(^PRC(442,PRCHPO,0),U,15)
+9 SET $PIECE(^(2),U)=+$PIECE($GET(^PRC(440.5,PRCHCD,2)),U)+PRCHPOMT
End DoDot:2
+10 SET PODA=DA
SET DA=CDA
SET X=$PIECE(^PRC(442,PRCHPO,0),U,15)
DO ESIG^PRCH410
SET DA=PODA
KILL PODA
End DoDot:1
+11 IF PRCHN("MP")=25
Begin DoDot:1
+12 IF $GET(PRCHPC)'=1
NEW PRCOPODA
SET PRCOPODA=PRCHPO
WRITE !!,"...now generating the PHA transaction"
DO ^PRCOEDI
+13 IF '$PIECE($GET(^PRC(442,PRCHPO,23)),U,11)
Begin DoDot:2
+14 IF '$PIECE(^PRC(442,PRCHPO,0),U,12)
SET DA=PRCHPO
DO START^PRCH410
Begin DoDot:3
+15 SET PODA=PRCHPO
SET DA=CDA
SET X=$PIECE(^PRC(442,PRCHPO,0),U,15)
DO ESIG^PRCH410
SET DA=PODA
KILL PODA
+16 ;Update file #440.5
+17 SET PRCHCD=+$PIECE(^PRC(442,PRCHPO,23),U,8)
+18 SET PRCHPOMT=$PIECE(^PRC(442,PRCHPO,0),U,15)
+19 SET $PIECE(^PRC(440.5,PRCHCD,2),U,1)=$PIECE(^PRC(440.5,PRCHCD,2),U,1)+PRCHPOMT
End DoDot:3
QUIT
+20 IF $PIECE(^PRC(442,PRCHPO,0),U,12)
DO COMM^PRCSPC(PRCHPO,$PIECE(^PRC(442,PRCHPO,0),U,10))
End DoDot:2
End DoDot:1
SET $PIECE(^PRC(442,PRCHPO,24),U)=1
GOTO INV
+21 ;
+22 IF $GET(PRCHSTAT)'=""
IF PRCHSTAT'=10
Begin DoDot:1
+23 NEW PRCOPODA
SET PRCOPODA=PRCHPO
DO ^PRCOEDI
DO SUPP^PRCFFMO
End DoDot:1
if $PIECE(^PRC(442,PRCHPO,0),U,2)=26
SET $PIECE(^PRC(442,PRCHPO,24),U)=1
GOTO INV
+24 IF $GET(PRCHOBL)=2
NEW PRCOPODA
SET PRCOPODA=PRCHPO
WRITE !!,"...now generating the PHA transaction"
DO ^PRCOEDI
+25 ;S PRCOPODA=PRCHPO I PRCHN("SFC")=2!$G(POCARD) D
+26 ;. D:'$G(POCARD) OBL D:$G(PRCHPC)'=1 ^PRCOEDI
+27 ;. I $G(POCARD)&($P(^PRC(442,PRCHPO,0),U,12)]"") D
+28 ;. . D COMM^PRCSPC(PRCHPO,$P(^PRC(442,PRCHPO,0),U,10)) Q
+29 ;. I $G(PRCHN("SFC"))=2 D SUPP^PRCFFMO W VAR2 H 2
INV SET DA=PRCHPO
DO UPDATE^PRCPWIU
+1 ;I $G(PRCH("SFC"))'=2,'$G(POCARD) D
+2 ;. I $G(PRCHOBL)=1 D:$G(PRCHPC)'=1 ^PRCOEDI D SUPP^PRCFFMO W VAR2 H 2
+3 ;. I $G(PRCHOBL)=2 D:$G(PRCHPC)'=1 ^PRCOEDI
+4 IF $DATA(PRCHNRQ)
if PRCHNRQ=""
SET PRCHNRQ=1
+5 IF '$GET(POCARD)
SET PRCHQ("DEST")="F"
SET D0=PRCHPO
SET PRCHQ="^PRCHFPNT"
DO ^PRCHQUE
+6 IF $GET(PRCHN("SFC"))=2!$GET(POCARD)
if '$GET(POCARD)
SET PRCHQ("DEST")="S"
SET D0=PRCHPO
SET PRCHQ="^PRCHFPNT"
DO ^PRCHQUE
+7 GOTO Q
+8 ;
QQ if '$DATA(ROUTINE)
SET ROUTINE=$TEXT(+0)
WRITE !!,$$ERR^PRCHQQ(ROUTINE,PRCSIG)
if PRCSIG=0!(PRCSIG=-3)
WRITE !,"Notify Application Coordinator!",$CHAR(7)
SET DIR(0)="EAO"
SET DIR("A")="Press <return> to continue"
DO ^DIR
KILL PRCSIG,ROUTINE
+1 QUIT
+2 ;
Q LOCK
DO Q^PRCHNPO4
KILL PRCF,PRCFA,PRCHENT,PRCHLOG,PRCHN,PRCHTYP,ROUTINE
+1 QUIT
+2 ;
ISMS ;CHECK ISMS SWITCH AND CREATE ISMS COD
+1 IF $$ISMSFLAG^PRCPUX2(PRC("SITE"))=2
SET PRCHTRAN=""
Begin DoDot:1
+2 IF PRCHSC=1
SET PRCHTRAN=$SELECT($PIECE(^PRC(442,PRCHPO,0),U,19)=2:"TO1",1:"SO1")
DO EN11^PRCHEI(PRCHTRAN)
+3 IF PRCHSC=9
SET PRCHTRAN="PO1"
DO EN11^PRCHEI(PRCHTRAN)
End DoDot:1
+4 GOTO Q
+5 ;
INC DO Q
GOTO ERR^PRCHNPO
+1 ;
OBL ;UPDATE CONTROL POINT OBLIGATED BALANCE
+1 IF $DATA(^PRC(442,PRCHPO,18))
IF $PIECE(^(18),U,12)
WRITE $CHAR(7),!,"This Supply Fund order has already updated the Control Point",!,"Obligated Balance.",!!
QUIT
+2 IF $DATA(PRCHN("SFC"))
IF PRCHN("SFC")=2
SET $PIECE(^PRC(442,PRCHPO,18),U,12)=1
+3 SET DA=+$PIECE(^PRC(442,PRCHPO,0),U,12)
if 'DA
GOTO ERR
if '$DATA(^PRCS(410,DA,0))
GOTO ERR
+4 IF $DATA(PRC("PER"))
SET PRCSIG=""
DO ENCODE^PRCSC2(DA,DUZ,.PRCSIG)
SET ROUTINE=$TEXT(+0)
IF PRCSIG<1
DO QQ
GOTO Q
+5 SET X=$PIECE(^PRCS(410,DA,4),"^",8)
DO TRANK^PRCSES
+6 SET X=$PIECE(^PRC(442,PRCHPO,0),U,16)
SET Y=$PIECE(^(0),U,10)
SET $PIECE(^PRCS(410,DA,4),"^",4)=DT
SET $PIECE(^(9),"^",2)=Y
SET $PIECE(^(4),"^",3)=X
SET $PIECE(^(4),"^",8)=X
DO TRANS^PRCSES
DO TRANS1^PRCSES
+7 QUIT
+8 ;
ERR WRITE $CHAR(7),!!,"Control Point Balances NOT updated!!"
+1 QUIT
+2 ;
W if '$DATA(PRCHLOG)
QUIT
WRITE $CHAR(7),!!,"WARNING--LOG code sheets have NOT been created!!"
+1 QUIT
+2 ;
W2 WRITE !!,$CHAR(7),"LOG code sheets for non-expendable good not yet programmed.",!,"Use FALCON or KEYPUNCH A CODESHEET option to create these.",!!
+1 QUIT
