PRCHREC ;ID/RSD,SF/TKW/RHD,DWA-PROCESS RECEIVING ;6/10/97 9:40
V ;;5.1;IFCAP;**22,81,191**;Oct 20, 2000;Build 4
;Per VA Directive 6402, this routine should not be modified.
;NOTE: VARIABLE 'PRCHIMP'-IMPREST FUND, 'PRCHPOO'-GENERATE PROOF OF ORDER ON GUARANTEED DELIVERY.
;
;PRC*5.1*191 Check order before entering receipts to insure there is
; no outstanding amendment (file 443.6) with any items that
; could overwrite the current items with new receipts in
; file 442. The previous check was ONLY looking for an
; amendment existing, but not if 443.6 entry created with
; no actual amendment as yet, only a record of each item
; transferred over.
;
S PRCF("X")="SP" D ^PRCFSITE Q:'$D(PRC("SITE"))!('$D(PRC("PER"))) I '$D(DT) D NOW^%DTC S DT=$P(%,".",1)
D SWITCH^PRCHUTL ;SET ISMS SWITCH
I '$D(PRCHAUTH),'$D(PRCHIMP),$S('$D(^VA(200,+PRC("PER"),400)):1,$P(^(400),U,1)=4:0,$P(^(400),U,1)=1:0,$P(^(400),U,1)=2:0,1:1) W !!,"You are not a Supply Warehouse person !",$C(7) Q
I ($D(PRCHIMP)!$D(PRCHAUTH)),'$D(^VA(200,+PRC("PER"),0)) W !!,"You are not on the Employee File!",$C(7) Q
;
EN I $D(PRCHPGM),PRCHPGM="EN5^PRCHEB" S PRCHIMP=1
S PRCHP("S")=$S($D(PRCHIMP):"$P(^(0),U,2)=7",1:"""178""[$P(^(0),U,2)!(($P(^(0),U,2)=""25"")&($P($G(^(23)),U,11)'=""S""))")
I $G(PRCHAUT1) S PRCHP("S")="$P($G(^(7)),U,2)>9,$P($G(^(23)),U,11)=""P"""
I $G(PRCHAUTH),'$G(PRCHAUT1) S PRCHP("S")="$P($G(^(7)),U,2)>9,$P($G(^(23)),U,11)=""D"",$P(^(0),U,2)'=26"
D EN3^PRCHPAT I '$D(PRCHPO) K CCARDPO,PRCHIMP,PRCHNRQ Q
I $G(PRCHAUTH) S PRCHAUCP=$P(^PRC(442,PRCHPO,0),U,3) D I $G(PRCHAUFG) K PRCHAUCP,PRCHAUFG Q
. I '$D(^PRC(420,PRC("SITE"),1,+PRCHAUCP,1,DUZ)) D S PRCHAUFG=1
. . W !!,"You are not an authorized user for "_$P(PRCHAUCP," ",1,2)_" control point.",!
K PRCHAUCP,PRCHAUFG
I $P($G(^PRC(442,PRCHPO,23)),U,11)="D",$P(^PRC(442,PRCHPO,1),U,10)=DUZ D Q
.W !,"Since you entered this delivery order, you cannot receive this order.",!
I $D(^PRC(443.6,PRCHPO)) S PRCHAM=$O(^PRC(443.6,PRCHPO,6,0)) D:$G(PRCHAM)]""
.I $P($G(^PRC(443.6,PRCHPO,6,PRCHAM,1)),U,2)]"" D
..W !!,?5,"Purchase Order "_$P(^PRC(442,PRCHPO,0),U)_" cannot be processed at this time due",!,?5,"to pending amendment action - please contact purchasing agent." S FIS=1
I $D(^PRC(443.6,PRCHPO,6)) S PRCHIT=$O(^PRC(443.6,PRCHPO,2,0)) D:PRCHIT]"" ;PRC*5.1*191
.W !!,?5,"Purchase Order "_$P(^PRC(442,PRCHPO,0),U)_" cannot be processed at this time due",!,?5,"to pending amendment w/ item info - please contact purchasing agent." S FIS=1 ;PRC*5.1*191
I $D(FIS) K PRCHAM,PRCHIT,FIS Q ;PRC*5.1*191
S PRCHENTY=$O(^PRC(442,PRCHPO,13,0))
S:$G(PRCHENTY) PRCP("I")=$P($G(^PRC(442,PRCHPO,13,PRCHENTY,0)),U,11)
I $G(PRCP("I")) S N=0,INVITEM=0 F S N=$O(^PRC(442,PRCHPO,2,N)) Q:'N!$G(INVITEM) S PRCHITM=$P(^PRC(442,PRCHPO,2,N,0),U,5) I PRCHITM'="",$D(^PRCP(445,PRCP("I"),1,PRCHITM)) S INVITEM=1
I $G(PRCHAUTH),$G(INVITEM) D ^PRCPAUTH Q:'$G(PRCP("I")) I $G(PRCP("I")),$G(PRCHFLAG)=1 K PRCHFLAG,NOINV Q
I $D(^PRC(442,PRCHPO,1)),$D(^VA(200,+$P(^(1),U,10),0)) W !,?13,"PA/PPM/AUTHORIZED BUYER: ",$P(^(0),U,1),!
I $P(^PRC(442,PRCHPO,0),U,2)'=25 I X<10!(X>29) W " ??",$C(7) G EN
I $P(^PRC(442,PRCHPO,0),U,2)=25 I X<10!(X>29)&(",32,34,39,44,46,47,"'[(","_X_",")) W " ??",$C(7) G EN
K PRCHNRQ,PRCHIMP S:$P(^PRC(442,PRCHPO,0),U,2)=8 PRCHNRQ=1 S:$P(^(0),U,2)=7 PRCHIMP=1
I $P(PRC("PARAM"),U,13)'="Y",X=10 W $C(7),!,?5,"This "_$S($D(PRCHNRQ):"REQUISITION",1:"PURCHASE ORDER")_" has not been obligated.",! G EN
D LCK1^PRCHE G:'$D(DA) Q K DIC("S") S D0=PRCHPO,%A="REVIEW "_$S($D(PRCHNRQ):"REQUISITION",1:"PURCHASE ORDER"),%B="",%=2 D ^PRCFYN G:%<1 Q D:%=1 ^PRCHDP1
;
1 R !!,"DATE RECEIVED: TODAY//",X:DTIME G:X="^"!'$T Q S %DT="EX",%DT(0)="-NOW" S:X="" X="TODAY" D ^%DT K %DT G:Y<0 1 I Y<$P(^PRC(442,PRCHPO,1),U,15) W !?3,"Receiving Date cannot be before P.O. date!",$C(7) G 1
I $D(^PRC(442,PRCHPO,2,"AB",Y)) D MULT^PRCHREC2 G:'$D(Y) 1
S PRCHRD=Y,PRCHRT0="",(PRCHRT,PRCHRFIN)=0 D TM^PRCHREC2 S:$P(^PRC(442,PRCHPO,7),U,3)="Y"&('$D(PRCHIMP)) PRCHRFIN=1
D ENTD^PRCHREC4 I PRCHDLVD["^" G EN
I $D(PRCHIMP) S X="C" G COM^PRCHREC1
K PRCHR
G LI^PRCHREC1
;
2 G:'$D(^PRC(442,PRCHPO,2,"AB",PRCHRD)) Q S PRCHRPT=0
I '$D(^PRC(442,PRCHPO,11,0)) S ^PRC(442,PRCHPO,11,0)="^442.11D^1^1",^(1,0)=PRCHRD_"^^^^",PRCHRPT=1
E S I=0 F S I=$O(^PRC(442,PRCHPO,11,I)) S:I=""!(I<0) PRCHRPT=PRCHRPT+1,$P(^(0),U,3,4)=PRCHRPT_U_($P(^(0),U,4)+1),^(PRCHRPT,0)=PRCHRD_"^^^^" Q:I=""!(I<0) S PRCHRPT=I
I $D(PRCHDLVD),PRCHDLVD]"" D UPDD^PRCHREC4
S (PRCHLC,PRCHRIT)=0 D SUB^PRCHREC2
S PRCHDPT=PRCHRPT,PRCHDRD=PRCHRD,PRCHDTP=0 D ^PRCHDP3
;
EN2 S (PRCHR,PRCHRES(1),PRCHRES(2))=0,Y=^PRC(442,PRCHPO,0) I $P(Y,U,6)]"",'$D(PRCHR("SA",$P(Y,U,6))) S PRCHR("SA",$P(Y,U,6))=U
I $P(Y,U,8)]"",'$D(PRCHR("SA",$P(Y,U,8))) S PRCHR("SA",$P(Y,U,8))=U
F I=1:1:2 S PRCHR=$O(PRCHR("SA",PRCHR)),X=$S(PRCHR<0!(PRCHR=""):"",1:PRCHR("SA",PRCHR)) S:PRCHR'<0 PRCHR(I)=PRCHR_U_$J(X,0,2) S:PRCHR<0 PRCHR(I)=U
I PRCHRPT=1 S PRCHRES(1)=+$P(^PRC(442,PRCHPO,0),U,13) S:+PRCHR(2) (PRCHRES(1),PRCHRES(2))=$J(PRCHRES(1)/2,0,2) F I=1:1:2 S $P(PRCHR(I),U,2)=$P(PRCHR(I),U,2)+PRCHRES(I)
S (PRCHRAM,PRCHRAMN)=$P(PRCHR(1),U,2)+$P(PRCHR(2),U,2),Y=0
F I=1:1:2 I +$P(PRCHR(I),U,2) S X=$P(PRCHR(I),U,2)-PRCHRES(I),X1=$J(X*PRCHRT,0,2),$P(PRCHR(I),U,2)=(X-X1+PRCHRES(I)),Y=Y+X1
I PRCHRT S PRCHRAMN=$J(PRCHRAM-Y,0,2) W:'$D(PRCHAV) !?38,"TERM DISCOUNT AMOUNT: ",?68,$J(Y,8,2),!?48,"NET AMOUNT: ",?66,$J(PRCHRAMN,10,2)
I '$P(PRCHR(1),U,2) S PRCHR(1)=PRCHR(2),PRCHR(2)="^"
F I=1:1:2 S:'$P(PRCHR(I),U,2) PRCHR(I)="^"
Q:$D(PRCHAV)
G ES^PRCHREC2
;
EN3 I PRCHRFIN K ^PRC(442,PRCHPO,2,"C")
S PRCHX=PRCHR(1)_U_PRCHR(2)_"^^^" D NOW^%DTC
I $P(^PRC(442,PRCHPO,0),U,19)'=3 S $P(^PRC(442,PRCHPO,11,PRCHRPT,1),U,6)="N",^PRC(442,"AF","N",PRCHPO,PRCHRPT)=""
S X=+$P($G(^PRCD(442.3,+^PRC(442,PRCHPO,7),0)),U,2),X1=$D(^PRC(442,PRCHPO,2,"C"))
S $P(PRCHX,U,8,13)=$S(X1:"",1:"F")_U_$S($D(PRCHROV):"Y",1:"")_U_%_U_PRCHRAM_U_PRCHRT0_U_PRCHLC,$P(^PRC(442,PRCHPO,11,PRCHRPT,0),U,2,14)=PRCHX,PRCSIG="" D ENCODE^PRCHES1(PRCHPO,PRCHRPT,DUZ,.PRCSIG) S ROUTINE=$T(+0) G:PRCSIG<1 QQ
I $P(^PRC(442,PRCHPO,0),U,2)'=25 D
. S:X1 X=$S(X=10:28,X=0:0,X=22:25,X=23:26,X=20:25,X=21:26,1:X)
. S:'X1 X=$S(X=10:33,$D(PRCHIMP):40,X=22:30,X=0:0,X=20:30,X=21:31,X=23:31,X=26:31,X=28:33,X=25:30,1:X)
I $P(^PRC(442,PRCHPO,0),U,2)=25 D
. S:X1 X=$S(X=10:28,X=0:0,X=20:25,X=21:26,X=22:25,X=23:26,X=24:32,X=29:34,X=39:46,X=44:47,1:X)
. S:'X1 X=$S(X=10:33,X=20:30,X=21:31,X=22:30,X=23:31,X=24:50,X=25:30,X=26:31,X=27:30,X=28:33,X=29:51,X=32:50,X=34:51,X=39:48,X=44:49,X=46:48,X=47:49,1:X)
I PRCHRFIN,$P($G(^PRC(442,PRCHPO,24)),U),$P($G(^PRC(442,PRCHPO,23)),U,11)="D" D
. I X=30 S X=40 Q
. I X=31 S X=41
I '$D(PRCHPOO) S DA=PRCHPO D ENS^PRCHSTAT
S X=$P(^PRC(442,PRCHPO,0),U,17),X=X+PRCHRAMN,$P(^(0),U,17)=X
D PRT^PRCHREC4
;
; PRC*5.1*81 - if site runs DynaMed, may need to build update txn
I $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")=1 D REC^PRCV442A(PRCHPO,PRCHRPT,1)
;
I $$ISMSFLAG^PRCPUX2(PRC("SITE"))=2 S PRCHSC=$P(^PRC(442,PRCHPO,1),U,7) I PRCHSC=7 S PRCHTRAN="RC1",DA=PRCHPO D EN11^PRCHEI(PRCHTRAN)
I $G(PRCHAUTH),'$D(NOINV),$G(INVITEM) D AUTH^PRCPPOLM I $G(PRCPFLAG)=1 D DELP^PRCHREC2
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 ROUTINE,PRCSIG
Q
;
Q S:$D(PRCHPOO) PRCFA("PARTIAL")=PRCHRPT
D KILL^PRCHREC4 K ROUTINE
Q:$D(PRCHPOO)
G EN
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCHREC 7653 printed Nov 22, 2024@17:20:16 Page 2
PRCHREC ;ID/RSD,SF/TKW/RHD,DWA-PROCESS RECEIVING ;6/10/97 9:40
V ;;5.1;IFCAP;**22,81,191**;Oct 20, 2000;Build 4
+1 ;Per VA Directive 6402, this routine should not be modified.
+2 ;NOTE: VARIABLE 'PRCHIMP'-IMPREST FUND, 'PRCHPOO'-GENERATE PROOF OF ORDER ON GUARANTEED DELIVERY.
+3 ;
+4 ;PRC*5.1*191 Check order before entering receipts to insure there is
+5 ; no outstanding amendment (file 443.6) with any items that
+6 ; could overwrite the current items with new receipts in
+7 ; file 442. The previous check was ONLY looking for an
+8 ; amendment existing, but not if 443.6 entry created with
+9 ; no actual amendment as yet, only a record of each item
+10 ; transferred over.
+11 ;
+12 SET PRCF("X")="SP"
DO ^PRCFSITE
if '$DATA(PRC("SITE"))!('$DATA(PRC("PER")))
QUIT
IF '$DATA(DT)
DO NOW^%DTC
SET DT=$PIECE(%,".",1)
+13 ;SET ISMS SWITCH
DO SWITCH^PRCHUTL
+14 IF '$DATA(PRCHAUTH)
IF '$DATA(PRCHIMP)
IF $SELECT('$DATA(^VA(200,+PRC("PER"),400)):1,$PIECE(^(400),U,1)=4:0,$PIECE(^(400),U,1)=1:0,$PIECE(^(400),U,1)=2:0,1:1)
WRITE !!,"You are not a Supply Warehouse person !",$CHAR(7)
QUIT
+15 IF ($DATA(PRCHIMP)!$DATA(PRCHAUTH))
IF '$DATA(^VA(200,+PRC("PER"),0))
WRITE !!,"You are not on the Employee File!",$CHAR(7)
QUIT
+16 ;
EN IF $DATA(PRCHPGM)
IF PRCHPGM="EN5^PRCHEB"
SET PRCHIMP=1
+1 SET PRCHP("S")=$SELECT($DATA(PRCHIMP):"$P(^(0),U,2)=7",1:"""178""[$P(^(0),U,2)!(($P(^(0),U,2)=""25"")&($P($G(^(23)),U,11)'=""S""))")
+2 IF $GET(PRCHAUT1)
SET PRCHP("S")="$P($G(^(7)),U,2)>9,$P($G(^(23)),U,11)=""P"""
+3 IF $GET(PRCHAUTH)
IF '$GET(PRCHAUT1)
SET PRCHP("S")="$P($G(^(7)),U,2)>9,$P($G(^(23)),U,11)=""D"",$P(^(0),U,2)'=26"
+4 DO EN3^PRCHPAT
IF '$DATA(PRCHPO)
KILL CCARDPO,PRCHIMP,PRCHNRQ
QUIT
+5 IF $GET(PRCHAUTH)
SET PRCHAUCP=$PIECE(^PRC(442,PRCHPO,0),U,3)
Begin DoDot:1
+6 IF '$DATA(^PRC(420,PRC("SITE"),1,+PRCHAUCP,1,DUZ))
Begin DoDot:2
+7 WRITE !!,"You are not an authorized user for "_$PIECE(PRCHAUCP," ",1,2)_" control point.",!
End DoDot:2
SET PRCHAUFG=1
End DoDot:1
IF $GET(PRCHAUFG)
KILL PRCHAUCP,PRCHAUFG
QUIT
+8 KILL PRCHAUCP,PRCHAUFG
+9 IF $PIECE($GET(^PRC(442,PRCHPO,23)),U,11)="D"
IF $PIECE(^PRC(442,PRCHPO,1),U,10)=DUZ
Begin DoDot:1
+10 WRITE !,"Since you entered this delivery order, you cannot receive this order.",!
End DoDot:1
QUIT
+11 IF $DATA(^PRC(443.6,PRCHPO))
SET PRCHAM=$ORDER(^PRC(443.6,PRCHPO,6,0))
if $GET(PRCHAM)]""
Begin DoDot:1
+12 IF $PIECE($GET(^PRC(443.6,PRCHPO,6,PRCHAM,1)),U,2)]""
Begin DoDot:2
+13 WRITE !!,?5,"Purchase Order "_$PIECE(^PRC(442,PRCHPO,0),U)_" cannot be processed at this time due",!,?5,"to pending amendment action - please contact purchasing agent."
SET FIS=1
End DoDot:2
End DoDot:1
+14 ;PRC*5.1*191
IF $DATA(^PRC(443.6,PRCHPO,6))
SET PRCHIT=$ORDER(^PRC(443.6,PRCHPO,2,0))
if PRCHIT]""
Begin DoDot:1
+15 ;PRC*5.1*191
WRITE !!,?5,"Purchase Order "_$PIECE(^PRC(442,PRCHPO,0),U)_" cannot be processed at this time due",!,?5,"to pending amendment w/ item info - please contact purchasing agent."
SET FIS=1
End DoDot:1
+16 ;PRC*5.1*191
IF $DATA(FIS)
KILL PRCHAM,PRCHIT,FIS
QUIT
+17 SET PRCHENTY=$ORDER(^PRC(442,PRCHPO,13,0))
+18 if $GET(PRCHENTY)
SET PRCP("I")=$PIECE($GET(^PRC(442,PRCHPO,13,PRCHENTY,0)),U,11)
+19 IF $GET(PRCP("I"))
SET N=0
SET INVITEM=0
FOR
SET N=$ORDER(^PRC(442,PRCHPO,2,N))
if 'N!$GET(INVITEM)
QUIT
SET PRCHITM=$PIECE(^PRC(442,PRCHPO,2,N,0),U,5)
IF PRCHITM'=""
IF $DATA(^PRCP(445,PRCP("I"),1,PRCHITM))
SET INVITEM=1
+20 IF $GET(PRCHAUTH)
IF $GET(INVITEM)
DO ^PRCPAUTH
if '$GET(PRCP("I"))
QUIT
IF $GET(PRCP("I"))
IF $GET(PRCHFLAG)=1
KILL PRCHFLAG,NOINV
QUIT
+21 IF $DATA(^PRC(442,PRCHPO,1))
IF $DATA(^VA(200,+$PIECE(^(1),U,10),0))
WRITE !,?13,"PA/PPM/AUTHORIZED BUYER: ",$PIECE(^(0),U,1),!
+22 IF $PIECE(^PRC(442,PRCHPO,0),U,2)'=25
IF X<10!(X>29)
WRITE " ??",$CHAR(7)
GOTO EN
+23 IF $PIECE(^PRC(442,PRCHPO,0),U,2)=25
IF X<10!(X>29)&(",32,34,39,44,46,47,"'[(","_X_","))
WRITE " ??",$CHAR(7)
GOTO EN
+24 KILL PRCHNRQ,PRCHIMP
if $PIECE(^PRC(442,PRCHPO,0),U,2)=8
SET PRCHNRQ=1
if $PIECE(^(0),U,2)=7
SET PRCHIMP=1
+25 IF $PIECE(PRC("PARAM"),U,13)'="Y"
IF X=10
WRITE $CHAR(7),!,?5,"This "_$SELECT($DATA(PRCHNRQ):"REQUISITION",1:"PURCHASE ORDER")_" has not been obligated.",!
GOTO EN
+26 DO LCK1^PRCHE
if '$DATA(DA)
GOTO Q
KILL DIC("S")
SET D0=PRCHPO
SET %A="REVIEW "_$SELECT($DATA(PRCHNRQ):"REQUISITION",1:"PURCHASE ORDER")
SET %B=""
SET %=2
DO ^PRCFYN
if %<1
GOTO Q
if %=1
DO ^PRCHDP1
+27 ;
1 READ !!,"DATE RECEIVED: TODAY//",X:DTIME
if X="^"!'$TEST
GOTO Q
SET %DT="EX"
SET %DT(0)="-NOW"
if X=""
SET X="TODAY"
DO ^%DT
KILL %DT
if Y<0
GOTO 1
IF Y<$PIECE(^PRC(442,PRCHPO,1),U,15)
WRITE !?3,"Receiving Date cannot be before P.O. date!",$CHAR(7)
GOTO 1
+1 IF $DATA(^PRC(442,PRCHPO,2,"AB",Y))
DO MULT^PRCHREC2
if '$DATA(Y)
GOTO 1
+2 SET PRCHRD=Y
SET PRCHRT0=""
SET (PRCHRT,PRCHRFIN)=0
DO TM^PRCHREC2
if $PIECE(^PRC(442,PRCHPO,7),U,3)="Y"&('$DATA(PRCHIMP))
SET PRCHRFIN=1
+3 DO ENTD^PRCHREC4
IF PRCHDLVD["^"
GOTO EN
+4 IF $DATA(PRCHIMP)
SET X="C"
GOTO COM^PRCHREC1
+5 KILL PRCHR
+6 GOTO LI^PRCHREC1
+7 ;
2 if '$DATA(^PRC(442,PRCHPO,2,"AB",PRCHRD))
GOTO Q
SET PRCHRPT=0
+1 IF '$DATA(^PRC(442,PRCHPO,11,0))
SET ^PRC(442,PRCHPO,11,0)="^442.11D^1^1"
SET ^(1,0)=PRCHRD_"^^^^"
SET PRCHRPT=1
+2 IF '$TEST
SET I=0
FOR
SET I=$ORDER(^PRC(442,PRCHPO,11,I))
if I=""!(I<0)
SET PRCHRPT=PRCHRPT+1
SET $PIECE(^(0),U,3,4)=PRCHRPT_U_($PIECE(^(0),U,4)+1)
SET ^(PRCHRPT,0)=PRCHRD_"^^^^"
if I=""!(I<0)
QUIT
SET PRCHRPT=I
+3 IF $DATA(PRCHDLVD)
IF PRCHDLVD]""
DO UPDD^PRCHREC4
+4 SET (PRCHLC,PRCHRIT)=0
DO SUB^PRCHREC2
+5 SET PRCHDPT=PRCHRPT
SET PRCHDRD=PRCHRD
SET PRCHDTP=0
DO ^PRCHDP3
+6 ;
EN2 SET (PRCHR,PRCHRES(1),PRCHRES(2))=0
SET Y=^PRC(442,PRCHPO,0)
IF $PIECE(Y,U,6)]""
IF '$DATA(PRCHR("SA",$PIECE(Y,U,6)))
SET PRCHR("SA",$PIECE(Y,U,6))=U
+1 IF $PIECE(Y,U,8)]""
IF '$DATA(PRCHR("SA",$PIECE(Y,U,8)))
SET PRCHR("SA",$PIECE(Y,U,8))=U
+2 FOR I=1:1:2
SET PRCHR=$ORDER(PRCHR("SA",PRCHR))
SET X=$SELECT(PRCHR<0!(PRCHR=""):"",1:PRCHR("SA",PRCHR))
if PRCHR'<0
SET PRCHR(I)=PRCHR_U_$JUSTIFY(X,0,2)
if PRCHR<0
SET PRCHR(I)=U
+3 IF PRCHRPT=1
SET PRCHRES(1)=+$PIECE(^PRC(442,PRCHPO,0),U,13)
if +PRCHR(2)
SET (PRCHRES(1),PRCHRES(2))=$JUSTIFY(PRCHRES(1)/2,0,2)
FOR I=1:1:2
SET $PIECE(PRCHR(I),U,2)=$PIECE(PRCHR(I),U,2)+PRCHRES(I)
+4 SET (PRCHRAM,PRCHRAMN)=$PIECE(PRCHR(1),U,2)+$PIECE(PRCHR(2),U,2)
SET Y=0
+5 FOR I=1:1:2
IF +$PIECE(PRCHR(I),U,2)
SET X=$PIECE(PRCHR(I),U,2)-PRCHRES(I)
SET X1=$JUSTIFY(X*PRCHRT,0,2)
SET $PIECE(PRCHR(I),U,2)=(X-X1+PRCHRES(I))
SET Y=Y+X1
+6 IF PRCHRT
SET PRCHRAMN=$JUSTIFY(PRCHRAM-Y,0,2)
if '$DATA(PRCHAV)
WRITE !?38,"TERM DISCOUNT AMOUNT: ",?68,$JUSTIFY(Y,8,2),!?48,"NET AMOUNT: ",?66,$JUSTIFY(PRCHRAMN,10,2)
+7 IF '$PIECE(PRCHR(1),U,2)
SET PRCHR(1)=PRCHR(2)
SET PRCHR(2)="^"
+8 FOR I=1:1:2
if '$PIECE(PRCHR(I),U,2)
SET PRCHR(I)="^"
+9 if $DATA(PRCHAV)
QUIT
+10 GOTO ES^PRCHREC2
+11 ;
EN3 IF PRCHRFIN
KILL ^PRC(442,PRCHPO,2,"C")
+1 SET PRCHX=PRCHR(1)_U_PRCHR(2)_"^^^"
DO NOW^%DTC
+2 IF $PIECE(^PRC(442,PRCHPO,0),U,19)'=3
SET $PIECE(^PRC(442,PRCHPO,11,PRCHRPT,1),U,6)="N"
SET ^PRC(442,"AF","N",PRCHPO,PRCHRPT)=""
+3 SET X=+$PIECE($GET(^PRCD(442.3,+^PRC(442,PRCHPO,7),0)),U,2)
SET X1=$DATA(^PRC(442,PRCHPO,2,"C"))
+4 SET $PIECE(PRCHX,U,8,13)=$SELECT(X1:"",1:"F")_U_$SELECT($DATA(PRCHROV):"Y",1:"")_U_%_U_PRCHRAM_U_PRCHRT0_U_PRCHLC
SET $PIECE(^PRC(442,PRCHPO,11,PRCHRPT,0),U,2,14)=PRCHX
SET PRCSIG=""
DO ENCODE^PRCHES1(PRCHPO,PRCHRPT,DUZ,.PRCSIG)
SET ROUTINE=$TEXT(+0)
if PRCSIG<1
GOTO QQ
+5 IF $PIECE(^PRC(442,PRCHPO,0),U,2)'=25
Begin DoDot:1
+6 if X1
SET X=$SELECT(X=10:28,X=0:0,X=22:25,X=23:26,X=20:25,X=21:26,1:X)
+7 if 'X1
SET X=$SELECT(X=10:33,$DATA(PRCHIMP):40,X=22:30,X=0:0,X=20:30,X=21:31,X=23:31,X=26:31,X=28:33,X=25:30,1:X)
End DoDot:1
+8 IF $PIECE(^PRC(442,PRCHPO,0),U,2)=25
Begin DoDot:1
+9 if X1
SET X=$SELECT(X=10:28,X=0:0,X=20:25,X=21:26,X=22:25,X=23:26,X=24:32,X=29:34,X=39:46,X=44:47,1:X)
+10 if 'X1
SET X=$SELECT(X=10:33,X=20:30,X=21:31,X=22:30,X=23:31,X=24:50,X=25:30,X=26:31,X=27:30,X=28:33,X=29:51,X=32:50,X=34:51,X=39:48,X=44:49,X=46:48,X=47:49,1:X)
End DoDot:1
+11 IF PRCHRFIN
IF $PIECE($GET(^PRC(442,PRCHPO,24)),U)
IF $PIECE($GET(^PRC(442,PRCHPO,23)),U,11)="D"
Begin DoDot:1
+12 IF X=30
SET X=40
QUIT
+13 IF X=31
SET X=41
End DoDot:1
+14 IF '$DATA(PRCHPOO)
SET DA=PRCHPO
DO ENS^PRCHSTAT
+15 SET X=$PIECE(^PRC(442,PRCHPO,0),U,17)
SET X=X+PRCHRAMN
SET $PIECE(^(0),U,17)=X
+16 DO PRT^PRCHREC4
+17 ;
+18 ; PRC*5.1*81 - if site runs DynaMed, may need to build update txn
+19 IF $$GET^XPAR("SYS","PRCV COTS INVENTORY",1,"Q")=1
DO REC^PRCV442A(PRCHPO,PRCHRPT,1)
+20 ;
+21 IF $$ISMSFLAG^PRCPUX2(PRC("SITE"))=2
SET PRCHSC=$PIECE(^PRC(442,PRCHPO,1),U,7)
IF PRCHSC=7
SET PRCHTRAN="RC1"
SET DA=PRCHPO
DO EN11^PRCHEI(PRCHTRAN)
+22 IF $GET(PRCHAUTH)
IF '$DATA(NOINV)
IF $GET(INVITEM)
DO AUTH^PRCPPOLM
IF $GET(PRCPFLAG)=1
DO DELP^PRCHREC2
+23 GOTO Q
+24 ;
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 ROUTINE,PRCSIG
+1 QUIT
+2 ;
Q if $DATA(PRCHPOO)
SET PRCFA("PARTIAL")=PRCHRPT
+1 DO KILL^PRCHREC4
KILL ROUTINE
+2 if $DATA(PRCHPOO)
QUIT
+3 GOTO EN
