- 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 Mar 13, 2025@21:08:02 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
