PRCFDSC1 ;WISC@ALTOONA/CTB-PRINT CI REGISTRATION SCREEN ;9/22/94 15:31
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
N PRCFA,I,X,Y,% S %=1
I $D(^PRC(442,D0))<10 S %=0 Q
F I=0,1 S PRCFA("PO",I)=$S($D(^PRC(442,D0,I))'["0":^(I),1:"")
F I=0,1 I PRCFA("PO",I)="" S %=0 K PRCFA("PO") Q
Q:$G(%)=0
S X=$O(^PRC(442,D0,5,0)),PRCFA("PO",5)=$S(X'?1.N:"",$D(^PRC(442,D0,5,X,0))#10:^(0),1:"")
S PRCFA("VE")=+PRCFA("PO",1) F I=0,3,7 S PRCFA("VE",I)=""
I PRCFA("VE")>0,$D(^PRC(440,PRCFA("VE")))>9 F I=0,3,7 S PRCFA("VE",I)=$G(^PRC(440,PRCFA("VE"),I))
S PRCFOUT="PRCFA(""ORD""," K PRCFA("ORD") S PRCFA("TMP",1)=$P(PRCFA("VE",0),"^",2,5),PRCFA("TMP",2)=$P(PRCFA("VE",0),"^",6,8) D ^PRCFDADD
S PRCFOUT="PRCFA(""PAY""," K PRCFA("PAY") S PRCFA("TMP",1)=$P(PRCFA("VE",7),"^",3,6),PRCFA("TMP",2)=$P(PRCFA("VE",7),"^",7,9) D ^PRCFDADD
S PRCFX(1,"Purchase Order #: ~!")=$P(PRCFA("PO",0),"^")
S Y=$P(PRCFA("PO",1),"^",15) D D^PRCFQ S PRCFX(2,"PO Date: ~?40")=Y
S X=$P(PRCFA("PO",1),"^",6),DD=442,F=6.4 D ^PRCFU1 S PRCFX(3,"FOB: ~!!?2")=Y
S Y="UNKNOWN",X=$P(PRCFA("PO",0),"^",2) I X>0,$D(^PRCD(442.5,+X,0)),$P(^(0),"^")]"" S Y=$P(^(0),"^")
S PRCFX(4,"Method of Payment: ~?35")=Y
S X=PRCFA("PO",5) S Y=$P(X,"^")_$S($P(X,"^")>0:"% ",1:" ")_$P(X,"^",2),PRCFX(5,"Terms: ~!")=Y
S Y="UNKNOWN",X=$P(PRCFA("PO",1),"^",10) I X>0,$D(^VA(200,+X,0)),$P(^(0),"^")]"" S Y=$P(^(0),"^")
S PRCFX(6,"P/A: ~?40")=Y
S Y=$S($P(PRCFA("PO",0),"^",3)]"":$P(PRCFA("PO",0),"^",3),1:"UNKNOWN"),PRCFX(7,"FCP: ~!?2")=Y
S PRCFX(8,"Vendor: ~!!?10")=$P(PRCFA("VE",0),"^")
S PRCFX(9,"FMS Vendor Code: ~!!?1")=$P(PRCFA("VE",3),U,4)
S PRCFX(10,"Alternate Address Indicator: ~?40")=$P(PRCFA("VE",3),U,5)
S PRCFX(11,"Ordering Address: ~!!")="",PRCFX(12,"Payment Address: ~?40")=""
S N=13 F I=1:1:8 I $D(PRCFA("ORD",I))!($D(PRCFA("PAY",I))) S PRCFX(N,"~!")=$G(PRCFA("ORD",I)),PRCFX(N+1,"~?40")=$G(PRCFA("PAY",I)),N=N+2
D ^PRCFSCR
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFDSC1 1969 printed Sep 23, 2025@19:39:19 Page 2
PRCFDSC1 ;WISC@ALTOONA/CTB-PRINT CI REGISTRATION SCREEN ;9/22/94 15:31
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 NEW PRCFA,I,X,Y,%
SET %=1
+3 IF $DATA(^PRC(442,D0))<10
SET %=0
QUIT
+4 FOR I=0,1
SET PRCFA("PO",I)=$SELECT($DATA(^PRC(442,D0,I))'["0":^(I),1:"")
+5 FOR I=0,1
IF PRCFA("PO",I)=""
SET %=0
KILL PRCFA("PO")
QUIT
+6 if $GET(%)=0
QUIT
+7 SET X=$ORDER(^PRC(442,D0,5,0))
SET PRCFA("PO",5)=$SELECT(X'?1.N:"",$DATA(^PRC(442,D0,5,X,0))#10:^(0),1:"")
+8 SET PRCFA("VE")=+PRCFA("PO",1)
FOR I=0,3,7
SET PRCFA("VE",I)=""
+9 IF PRCFA("VE")>0
IF $DATA(^PRC(440,PRCFA("VE")))>9
FOR I=0,3,7
SET PRCFA("VE",I)=$GET(^PRC(440,PRCFA("VE"),I))
+10 SET PRCFOUT="PRCFA(""ORD"","
KILL PRCFA("ORD")
SET PRCFA("TMP",1)=$PIECE(PRCFA("VE",0),"^",2,5)
SET PRCFA("TMP",2)=$PIECE(PRCFA("VE",0),"^",6,8)
DO ^PRCFDADD
+11 SET PRCFOUT="PRCFA(""PAY"","
KILL PRCFA("PAY")
SET PRCFA("TMP",1)=$PIECE(PRCFA("VE",7),"^",3,6)
SET PRCFA("TMP",2)=$PIECE(PRCFA("VE",7),"^",7,9)
DO ^PRCFDADD
+12 SET PRCFX(1,"Purchase Order #: ~!")=$PIECE(PRCFA("PO",0),"^")
+13 SET Y=$PIECE(PRCFA("PO",1),"^",15)
DO D^PRCFQ
SET PRCFX(2,"PO Date: ~?40")=Y
+14 SET X=$PIECE(PRCFA("PO",1),"^",6)
SET DD=442
SET F=6.4
DO ^PRCFU1
SET PRCFX(3,"FOB: ~!!?2")=Y
+15 SET Y="UNKNOWN"
SET X=$PIECE(PRCFA("PO",0),"^",2)
IF X>0
IF $DATA(^PRCD(442.5,+X,0))
IF $PIECE(^(0),"^")]""
SET Y=$PIECE(^(0),"^")
+16 SET PRCFX(4,"Method of Payment: ~?35")=Y
+17 SET X=PRCFA("PO",5)
SET Y=$PIECE(X,"^")_$SELECT($PIECE(X,"^")>0:"% ",1:" ")_$PIECE(X,"^",2)
SET PRCFX(5,"Terms: ~!")=Y
+18 SET Y="UNKNOWN"
SET X=$PIECE(PRCFA("PO",1),"^",10)
IF X>0
IF $DATA(^VA(200,+X,0))
IF $PIECE(^(0),"^")]""
SET Y=$PIECE(^(0),"^")
+19 SET PRCFX(6,"P/A: ~?40")=Y
+20 SET Y=$SELECT($PIECE(PRCFA("PO",0),"^",3)]"":$PIECE(PRCFA("PO",0),"^",3),1:"UNKNOWN")
SET PRCFX(7,"FCP: ~!?2")=Y
+21 SET PRCFX(8,"Vendor: ~!!?10")=$PIECE(PRCFA("VE",0),"^")
+22 SET PRCFX(9,"FMS Vendor Code: ~!!?1")=$PIECE(PRCFA("VE",3),U,4)
+23 SET PRCFX(10,"Alternate Address Indicator: ~?40")=$PIECE(PRCFA("VE",3),U,5)
+24 SET PRCFX(11,"Ordering Address: ~!!")=""
SET PRCFX(12,"Payment Address: ~?40")=""
+25 SET N=13
FOR I=1:1:8
IF $DATA(PRCFA("ORD",I))!($DATA(PRCFA("PAY",I)))
SET PRCFX(N,"~!")=$GET(PRCFA("ORD",I))
SET PRCFX(N+1,"~?40")=$GET(PRCFA("PAY",I))
SET N=N+2
+26 DO ^PRCFSCR
