- 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 Mar 13, 2025@21:06:44 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
