PRCSRCD ;ISC-SF/TKW-ALLOW ENTRY OF DATE RECEIVED ;10/11/91  10:27
V ;;5.1;IFCAP;;Oct 20, 2000
 ;Per VHA Directive 10-93-142, this routine should not be modified.
EN1 ; LOOP THROUGH TRX.BY CONTROL POINT
 K PRC D EN3^PRCSUT G:'$D(PRC("SITE"))!('$D(PRC("CP"))) EXIT
 W ! S PRCSI="",PRCSCP=$P(PRC("CP")," ",1),PRCSLOOP=1 D RD1 W !,"***LAST TRANSACTION***",! G EXIT
RD1 S PRCSI=$O(^PRCS(410,"AN",PRC("CP"),PRCSI)) Q:'PRCSI  G:'$D(^PRCS(410,PRCSI,0)) RD1 G:$P(^(0),"^",2)'="O" RD1 W "." S X=PRCSI
 G:'$D(^PRCS(410,X,4)) RD1 G:$P(^(4),"^",5)="" RD1
 I $D(^PRCS(410,X,9)),$P(^(9),"^",3) G RD1
 S PRCSDT="",PRCSPO=$S($D(^PRCS(410,X,10)):+$P(^(10),"^",3),1:0) I '$D(^PRC(442,PRCSPO,0)) D RD2 G RD1
 S X=$P(^PRC(442,PRCSPO,0),"^",2) I (X>1)&(X<5) D RD2 G RD1
 S PRCSFINL=0 F I=0:0 S I=$O(^PRC(442,PRCSPO,11,I)) Q:'I  I $D(^(I,0)),$P(^(0),U,9)="F" S PRCSFINL=1 Q
 G:'PRCSFINL RD1
 D RD2 Q:'PRCSLOOP  G RD1
RD2 W !,$P(^PRCS(410,PRCSI,0),"^",1),?20,"P.O.: "_$P(^(4),"^",5)
 I $D(^PRC(442,PRCSPO,0)) W "     "_$S($D(^PRCD(442.5,+$P(^(0),U,2),0)):$E($P(^(0),U,1),1,16),1:"") S Y=$S($D(^PRC(442,PRCSPO,1)):$P(^(1),U,15),1:"") I Y D DD^%DT W "     P.O.DATE: "_Y
 ;W ! F PRCSP=0:0 S PRCSP=$O(^PRC(442,PRCSPO,11,PRCSP)) Q:'PRCSP  I $D(^(PRCSP,0)) W ?25,"PARTIAL#: ",PRCSP,?45 W:$P(^(0),U,9)="F" "*FINAL*" W ?54,"DATE: " S Y=$P(+$P(^(0),"^",1),".",1) D DD^%DT W Y,! S PRCSDT=Y
 S DR=48
 S DIE="^PRCS(410,",DA=PRCSI D ^DIE W ! S:$D(Y) PRCSLOOP=0 Q
EN2 ;ENTER DATE RECEIVED ON SINGLE TRX.
 D EN3^PRCSUT G:'$D(PRC("SITE"))!(Y<0)!('$D(PRC("CP"))) EXIT
E2 K D W !! S DIC="^PRCS(410,",DIE=DIC,DIC(0)="AEQM",DIC("A")="Select TRANSACTION or P.O. NUMBER: "
 S DIC("S")="I +^(0),$D(^(3)),+^(3)=+PRC(""CP""),$P(^(0),""^"",5)=PRC(""SITE""),$P(^(0),""^"",2)=""O"" I $D(^PRC(420,""A"",DUZ,PRC(""SITE""),+PRC(""CP""),1))!($D(^(2)))"
 D ^PRCSDIC G EXIT:Y<0 K DIC("S") S PRCSI=+Y
 I '$D(^PRCS(410,+Y,4)) G W S PRCSPO=$P(^(4),"^",5) I PRCSPO="" G W
 S PRCSDT="",PRCSPO=$S($D(^PRCS(410,+Y,10)):+$P(^(10),"^",3),1:0) I '$D(^PRC(442,PRCSPO,0)) D RD2 G E2
 S X=$P(^PRC(442,PRCSPO,0),"^",2) I (X>1)&(X<5) D RD2 G E2
 S PRCSFINL=0 F I=0:0 S I=$O(^PRC(442,PRCSPO,11,I)) Q:'I  I $D(^(I,0)),$P(^(0),U,9)="F" S PRCSFINL=1 Q
 G:'PRCSFINL E2
 D RD2 G E2
W W !,$C(7),"NO P.O.HAS BEEN ENTERED FOR THIS TRANSACTION!" G E2
W2 W !,$C(7),"FINAL PARTIAL HAS NOT BEEN ENTERED FOR THIS P.O.!" G E2
EXIT K PRC,PRCSI,PRCSCP,PRCSFINL,PRCSFY,PRCSIP,PRCSQ,PRCSX,PRCSDT,PRCSP,PRCSPO,X,Y,I,J,DIE,DR,DA,DIC,D0 Q