PRCFAC4 ;WISC@ALTOONA/CTB-PRINT PO OBLIGATION HISTORY ;2/12/98 2:27 PM
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
S U="^",DIC="^PRC(442,",DIC(0)="AEQM",CNT=0,DIC("A")="PURCHASE ORDER NUMBER: " K ^TMP($J),^(U,$J)
F PRCFI=1:1 D ^DIC Q:Y<0 S CNT=CNT+1,^TMP(U,$J,+Y)="",DIC("A")="ANOTHER ONE: "
K DIC,PRCFI G Q:'CNT F D0=0:0 S D0=$O(^TMP(U,$J,D0)) Q:'D0 D B
K PRCFI,PO G Q
B ;DISPLAY SINGLE HISTORY
I $D(IOF),IOST'["PK-" W @IOF
E W !!
K PO F I=0,1,7 S PO(I)=$S($D(^PRC(442,D0,I)):^(I),1:"")
W !,?22,"PURCHASE ORDER NUMBER: ",$P(PO(0),U),!
W !,?2,"DATE: " S Y=$P(PO(1),U,15) D DT
W ?40,"FCP: " W $E($P(PO(0),U,3),1,30)
W !?2,"STATUS: " S X=$P(PO(7),"^"),Y=$S($D(^PRCD(442.3,+X,0))#2:$E($P(^(0),U,1),1,30),1:"") W Y
W !?2,"VENDOR: " S X=$P(PO(1),"^"),Y=$S($D(^PRC(440,+X,0))#2:$E($P(^(0),U,1),1,36),1:"") W Y
W ?49,"TOTAL: " S X=$P(PO(0),"^",15) W $J(X,11,2)
S N=0
LINE D HDR F LI=8:1:IOSL-4 S N=$O(^PRC(442,D0,10,N)) G PO:N="" S X=^(N,0) S X2=$P(X,"^",6),X1=$P(X,"^"),X3=$P(X,"^",2) S:X2="" X2=$E($P(X1,".",4),7,99) D WL
D ASK Q:ASK G LINE
PO W ! S %A="Would you like to review the entire purchase order",%B="" S %=2 D ^PRCFYN Q:%'=1 S PRC("SITE")=+PO(0) D ^PRCHDP1 Q
WL W !?2,$P(X1,".",1,2),?10,$P(X1,".",3),?19,$E($P(X1,".",4),1,6),?27 S Y=X2 D:+Y'=0 DD^%DT W Y Q:+X3=0 W:$D(^VA(200,X3,0)) ?49,$P(^(0),"^") Q
DT I Y W Y\100#100,"/",Y#100\1,"/",Y\10000+1700
Q
HDR S (ASK,D1)=0 W !!,"FMS DOCUMENT(S): ",!,?2,"TT/SC",?10,"TR DATE",?19,"REF",?27,"SIG DATE/TIME",?49,"SIGNED BY:" Q
ASK W !!,"Press RETURN to continue, '^' to Quit" R X:$S($D(DTIME):DTIME,1:300) S:X["^"!(N="") ASK=1 I $D(IOF) W @IOF
Q
Q K %,%W,ASK,DI,DIC,CNT,DA,D0,D1,DIWL,DIWR,I,J,K,LI,N,PO,POP,PRCHPO,^TMP($J),^(U,$J),X,X1,X2,X3,Y,Z Q
EN4 ;PRINT PO FOR RECEIVING
S PRCF("X")="ASP" D ^PRCFSITE
EN40 D PO^PRCHRPT G:'$D(PRCHPO) EN4Q I X<10!(X>44) W " ??",$C(7) G EN40
S Y=0 I $D(^PRC(442,DA,11,0)) S DIC="^PRC(442,DA,11,",DIC(0)="NEAZ",DIC("A")="RECEIVING REPORT DATE: " D ^DIC
I Y>0 K PRCHQ("DEST2") S PRCHFPT=+Y,D0=PRCHPO,PRCHQ="^PRCHFPNT",PRCHQ("DEST")="R",PRCHQ("DEST2")="FR" D ^PRCHQUE,EN4Q
G EN40
EN4Q K PRCHFPT,PRCHQ,PRCHPO,DIC,D0 Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFAC4 2213 printed Nov 22, 2024@17:12:02 Page 2
PRCFAC4 ;WISC@ALTOONA/CTB-PRINT PO OBLIGATION HISTORY ;2/12/98 2:27 PM
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 SET U="^"
SET DIC="^PRC(442,"
SET DIC(0)="AEQM"
SET CNT=0
SET DIC("A")="PURCHASE ORDER NUMBER: "
KILL ^TMP($JOB),^(U,$JOB)
+3 FOR PRCFI=1:1
DO ^DIC
if Y<0
QUIT
SET CNT=CNT+1
SET ^TMP(U,$JOB,+Y)=""
SET DIC("A")="ANOTHER ONE: "
+4 KILL DIC,PRCFI
if 'CNT
GOTO Q
FOR D0=0:0
SET D0=$ORDER(^TMP(U,$JOB,D0))
if 'D0
QUIT
DO B
+5 KILL PRCFI,PO
GOTO Q
B ;DISPLAY SINGLE HISTORY
+1 IF $DATA(IOF)
IF IOST'["PK-"
WRITE @IOF
+2 IF '$TEST
WRITE !!
+3 KILL PO
FOR I=0,1,7
SET PO(I)=$SELECT($DATA(^PRC(442,D0,I)):^(I),1:"")
+4 WRITE !,?22,"PURCHASE ORDER NUMBER: ",$PIECE(PO(0),U),!
+5 WRITE !,?2,"DATE: "
SET Y=$PIECE(PO(1),U,15)
DO DT
+6 WRITE ?40,"FCP: "
WRITE $EXTRACT($PIECE(PO(0),U,3),1,30)
+7 WRITE !?2,"STATUS: "
SET X=$PIECE(PO(7),"^")
SET Y=$SELECT($DATA(^PRCD(442.3,+X,0))#2:$EXTRACT($PIECE(^(0),U,1),1,30),1:"")
WRITE Y
+8 WRITE !?2,"VENDOR: "
SET X=$PIECE(PO(1),"^")
SET Y=$SELECT($DATA(^PRC(440,+X,0))#2:$EXTRACT($PIECE(^(0),U,1),1,36),1:"")
WRITE Y
+9 WRITE ?49,"TOTAL: "
SET X=$PIECE(PO(0),"^",15)
WRITE $JUSTIFY(X,11,2)
+10 SET N=0
LINE DO HDR
FOR LI=8:1:IOSL-4
SET N=$ORDER(^PRC(442,D0,10,N))
if N=""
GOTO PO
SET X=^(N,0)
SET X2=$PIECE(X,"^",6)
SET X1=$PIECE(X,"^")
SET X3=$PIECE(X,"^",2)
if X2=""
SET X2=$EXTRACT($PIECE(X1,".",4),7,99)
DO WL
+1 DO ASK
if ASK
QUIT
GOTO LINE
PO WRITE !
SET %A="Would you like to review the entire purchase order"
SET %B=""
SET %=2
DO ^PRCFYN
if %'=1
QUIT
SET PRC("SITE")=+PO(0)
DO ^PRCHDP1
QUIT
WL WRITE !?2,$PIECE(X1,".",1,2),?10,$PIECE(X1,".",3),?19,$EXTRACT($PIECE(X1,".",4),1,6),?27
SET Y=X2
if +Y'=0
DO DD^%DT
WRITE Y
if +X3=0
QUIT
if $DATA(^VA(200,X3,0))
WRITE ?49,$PIECE(^(0),"^")
QUIT
DT IF Y
WRITE Y\100#100,"/",Y#100\1,"/",Y\10000+1700
+1 QUIT
HDR SET (ASK,D1)=0
WRITE !!,"FMS DOCUMENT(S): ",!,?2,"TT/SC",?10,"TR DATE",?19,"REF",?27,"SIG DATE/TIME",?49,"SIGNED BY:"
QUIT
ASK WRITE !!,"Press RETURN to continue, '^' to Quit"
READ X:$SELECT($DATA(DTIME):DTIME,1:300)
if X["^"!(N="")
SET ASK=1
IF $DATA(IOF)
WRITE @IOF
+1 QUIT
Q KILL %,%W,ASK,DI,DIC,CNT,DA,D0,D1,DIWL,DIWR,I,J,K,LI,N,PO,POP,PRCHPO,^TMP($JOB),^(U,$JOB),X,X1,X2,X3,Y,Z
QUIT
EN4 ;PRINT PO FOR RECEIVING
+1 SET PRCF("X")="ASP"
DO ^PRCFSITE
EN40 DO PO^PRCHRPT
if '$DATA(PRCHPO)
GOTO EN4Q
IF X<10!(X>44)
WRITE " ??",$CHAR(7)
GOTO EN40
+1 SET Y=0
IF $DATA(^PRC(442,DA,11,0))
SET DIC="^PRC(442,DA,11,"
SET DIC(0)="NEAZ"
SET DIC("A")="RECEIVING REPORT DATE: "
DO ^DIC
+2 IF Y>0
KILL PRCHQ("DEST2")
SET PRCHFPT=+Y
SET D0=PRCHPO
SET PRCHQ="^PRCHFPNT"
SET PRCHQ("DEST")="R"
SET PRCHQ("DEST2")="FR"
DO ^PRCHQUE
DO EN4Q
+3 GOTO EN40
EN4Q KILL PRCHFPT,PRCHQ,PRCHPO,DIC,D0
QUIT
