- 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 Feb 18, 2025@23:44:40 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
