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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCSRCD 2477 printed Dec 13, 2024@02:18:18 Page 2
PRCSRCD ;ISC-SF/TKW-ALLOW ENTRY OF DATE RECEIVED ;10/11/91 10:27
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
EN1 ; LOOP THROUGH TRX.BY CONTROL POINT
+1 KILL PRC
DO EN3^PRCSUT
if '$DATA(PRC("SITE"))!('$DATA(PRC("CP")))
GOTO EXIT
+2 WRITE !
SET PRCSI=""
SET PRCSCP=$PIECE(PRC("CP")," ",1)
SET PRCSLOOP=1
DO RD1
WRITE !,"***LAST TRANSACTION***",!
GOTO EXIT
RD1 SET PRCSI=$ORDER(^PRCS(410,"AN",PRC("CP"),PRCSI))
if 'PRCSI
QUIT
if '$DATA(^PRCS(410,PRCSI,0))
GOTO RD1
if $PIECE(^(0),"^",2)'="O"
GOTO RD1
WRITE "."
SET X=PRCSI
+1 if '$DATA(^PRCS(410,X,4))
GOTO RD1
if $PIECE(^(4),"^",5)=""
GOTO RD1
+2 IF $DATA(^PRCS(410,X,9))
IF $PIECE(^(9),"^",3)
GOTO RD1
+3 SET PRCSDT=""
SET PRCSPO=$SELECT($DATA(^PRCS(410,X,10)):+$PIECE(^(10),"^",3),1:0)
IF '$DATA(^PRC(442,PRCSPO,0))
DO RD2
GOTO RD1
+4 SET X=$PIECE(^PRC(442,PRCSPO,0),"^",2)
IF (X>1)&(X<5)
DO RD2
GOTO RD1
+5 SET PRCSFINL=0
FOR I=0:0
SET I=$ORDER(^PRC(442,PRCSPO,11,I))
if 'I
QUIT
IF $DATA(^(I,0))
IF $PIECE(^(0),U,9)="F"
SET PRCSFINL=1
QUIT
+6 if 'PRCSFINL
GOTO RD1
+7 DO RD2
if 'PRCSLOOP
QUIT
GOTO RD1
RD2 WRITE !,$PIECE(^PRCS(410,PRCSI,0),"^",1),?20,"P.O.: "_$PIECE(^(4),"^",5)
+1 IF $DATA(^PRC(442,PRCSPO,0))
WRITE " "_$SELECT($DATA(^PRCD(442.5,+$PIECE(^(0),U,2),0)):$EXTRACT($PIECE(^(0),U,1),1,16),1:"")
SET Y=$SELECT($DATA(^PRC(442,PRCSPO,1)):$PIECE(^(1),U,15),1:"")
IF Y
DO DD^%DT
WRITE " P.O.DATE: "_Y
+2 ;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
+3 SET DR=48
+4 SET DIE="^PRCS(410,"
SET DA=PRCSI
DO ^DIE
WRITE !
if $DATA(Y)
SET PRCSLOOP=0
QUIT
EN2 ;ENTER DATE RECEIVED ON SINGLE TRX.
+1 DO EN3^PRCSUT
if '$DATA(PRC("SITE"))!(Y<0)!('$DATA(PRC("CP")))
GOTO EXIT
E2 KILL D
WRITE !!
SET DIC="^PRCS(410,"
SET DIE=DIC
SET DIC(0)="AEQM"
SET DIC("A")="Select TRANSACTION or P.O. NUMBER: "
+1 SET 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)))"
+2 DO ^PRCSDIC
if Y<0
GOTO EXIT
KILL DIC("S")
SET PRCSI=+Y
+3 IF '$DATA(^PRCS(410,+Y,4))
GOTO W
SET PRCSPO=$PIECE(^(4),"^",5)
IF PRCSPO=""
GOTO W
+4 SET PRCSDT=""
SET PRCSPO=$SELECT($DATA(^PRCS(410,+Y,10)):+$PIECE(^(10),"^",3),1:0)
IF '$DATA(^PRC(442,PRCSPO,0))
DO RD2
GOTO E2
+5 SET X=$PIECE(^PRC(442,PRCSPO,0),"^",2)
IF (X>1)&(X<5)
DO RD2
GOTO E2
+6 SET PRCSFINL=0
FOR I=0:0
SET I=$ORDER(^PRC(442,PRCSPO,11,I))
if 'I
QUIT
IF $DATA(^(I,0))
IF $PIECE(^(0),U,9)="F"
SET PRCSFINL=1
QUIT
+7 if 'PRCSFINL
GOTO E2
+8 DO RD2
GOTO E2
W WRITE !,$CHAR(7),"NO P.O.HAS BEEN ENTERED FOR THIS TRANSACTION!"
GOTO E2
W2 WRITE !,$CHAR(7),"FINAL PARTIAL HAS NOT BEEN ENTERED FOR THIS P.O.!"
GOTO E2
EXIT KILL PRC,PRCSI,PRCSCP,PRCSFINL,PRCSFY,PRCSIP,PRCSQ,PRCSX,PRCSDT,PRCSP,PRCSPO,X,Y,I,J,DIE,DR,DA,DIC,D0
QUIT
