PRCFDA1 ;WISC@ALTOONA/CTB-PROCESS PAYMENT TO FMS ;6/8/94 2:17 PM
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
I $D(PRC("SITE")),PRC("SITE")]"",$D(^PRC(411,PRC("SITE"),0)) S PRC("PARAM")=^(0)
F I=0,1,2 S P(I)=$G(^PRCF(421.5,PRCF("CIDA"),I))
S PRCFX(1,"~")="FMS PAYMENT VOUCHER",PRCFX(1.5,"Invoice ID#: ~?48")=$P(P(0),"^")
S X=$P(P(0),"^",27),DD=421.5,F=.6 D ^PRCFU1 S PRCFX(2,"Certification Required? ~!!")=$S(%:Y,1:"")
;S PRCFX(3,"Document Locator Number: ~?38")=$P(P(0),"^",2)
S PRCFX(4,"Invoice Number: ")=$P(P(0),"^",3)
S Y=$P(P(0),"^",4) D D^PRCFQ S PRCFX(5,"Date of Invoice: ~?38")=Y
S Y=$P(P(0),"^",5) D D^PRCFQ S PRCFX(5.5,"Date Invoice Received: ")=Y
S Y=$P(P(0),"^",21) D D^PRCFQ S PRCFX(5.7,"Date Goods/Services Received: ~?48")=Y
S X=$P(P(0),"^",6),DD=421.5,F=4 D ^PRCFU1 S PRCFX(5.8,"Invoice Type: ~!")=$S(%:Y,1:"")
S XX=$P(P(0),"^",8),PRCFX(6,"Vendor: ~!!")=$S(+XX=0:"",'$D(^PRC(440,XX,0))#2:"",1:$P(^(0),"^")) K XX
S PRCFX(7,"FMS Vendor ID#: ~!")=$P(P(0),"^",10)
;S PRCFX(8,"Vendor Stub Name: ")=$P(P(0),"^",9)
S PRCFX(9,"Total Payment: $ ~!!")=$J($P(P(0),"^",15)/100,0,2)
S PRCFX(10,"Shipping: $ ")=$J($P(P(0),"^",14)/100,0,2)
S PRCFX(11,"Discount %: ~!")=$S(+$P(P(0),"^",11)=0:"NET "_$P(P(1),"^",10),1:+$P(P(0),"^",11)_"% "_$P(P(0),"^",12)_" Days, NET "_$P(P(1),"^",10))
S:$P(P(0),"^",26)]"" PRCFX(11.5,"Discount Amount: ")=$J($P(P(0),"^",26),0,2)
;S X=$P(P(0),"^",23),DD=421.5,F=20 D ^PRCFU1 S PRCFX(19,"Interest Indicator: ~!!")=$S(%:Y,1:"")
;S X=$P(P(0),"^",22),DD=421.5,F=19 D ^PRCFU1 S PRCFX(20,"Money Management Status: ")=$S(%:Y,1:"")
S X=$P(P(0),"^",16),DD=421.5,F=14 D ^PRCFU1 S PRCFX(14,"Liquidation Code: ~!")=$S(%:Y,1:"")
S PRCFX(15,"BOC #1: ~!")=$P(P(0),"^",17) S PRCFX(16,"Liquidation Amt #1: $ ~?38")=$J($P(P(0),"^",19)/100,0,2)
S PRCFX(17,"BOC #2: ~!")=$P(P(0),"^",18) S PRCFX(18,"Liquidation Amt #2: $ ~?38")=$J($P(P(0),"^",20)/100,0,2)
D ^PRCFSCR S %A="Are you ready to release this invoice to FMS",%B="",%=1 D ^PRCFYN
I %'=1 S X=" <Action Terminated>*" D MSG^PRCFQ G OUT
S PRCFA("TTF")="900.00",PRCFASYS="CAP" D TT^PRCFAC
I %'=1 S X="Unable to select CAPPS transaction type 900.00. Please try again." D MSG^PRCFQ G OUT
I ^PRCF(421.5,PRCF("CIDA"),2),$P($P(^(2),"^",3),"-",2)]"" S PRCFA("REF")=$P($P(^(2),"^",3),"-",2)
D NEWCS^PRCFAC I '$D(DA) S X="No new FMS document created - Files inaccessible at this time.*" D MSG^PRCFQ G OUT
S X="Transferring invoice data to CAPPS transmittal document.*" D MSG^PRCFQ
K F,T F I=0,1,2 S F(I)=$S($D(^PRCF(421.5,PRCF("CIDA"),I)):^(I),1:"")
F I=0,1,6,100 S T(I)=$S($D(^PRCF(423,PRCFA("CSDA"),I)):^(I),1:"")
S $P(T(100),"^",1,6)="C^"_$P(F(0),"^",2,6)
S $P(T(100),"^",11,16)=$P(F(0),"^",11,16)
S $P(T(100),"^",17,23)=$P(F(0),"^",17,23)
F I=16,17,18 S $P(T(100),"^",I+12)=$P(F(1),"^",I)
S $P(T(1),"^",18)=$P(F(0),"^",9),$P(T(6),"^",7)=$P(F(0),"^",10),$P(T(100),"^",27)=$P(F(0),"^",26)
S $P(T(1),"^",8)=$P(F(0),"^",17),$P(T(1),"^",10)=$P(F(0),"^",18)
S $P(T(100),"^",26)=$P(F(2),"^",2),$P(T(1),"^",16)="~"
F I=0,1,6,100 S ^PRCF(423,PRCFA("CSDA"),I)=T(I)
K F,T S PRCF("OUT")=""
S PRCFA("PAYMENT")="" D ^PRCFACXM K PRCFA("PAYMENT")
I $D(PRCFDEL)!$D(PRCFA("CSHOLD")) S X="Transmittal document was "_$S($D(PRCFDEL):"DELETED",1:"NOT TRANSMITTED")_". All further action on this invoice is suspended.*"
I D MSG^PRCFQ K PRCFDEL,PRCFA("CSHOLD") S X=$P(^PRCF(421.5,PRCF("CIDA"),2),"^") I 1
E D
.S DA=PRCF("CIDA"),MESSAGE=""
.D REMOVE^PRCFDES2(DA),ENCODE^PRCFDES2(DA,DUZ,.MESSAGE)
.K MESSAGE S X=20
.Q
K PRCF("OUT") D STATUS^PRCFDE1
X D OUT^PRCFDE K PRCFASYS G ^PRCFDA
OUT D OUT^PRCFDE K PRCFASYS Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFDA1 3713 printed Dec 13, 2024@02:02:45 Page 2
PRCFDA1 ;WISC@ALTOONA/CTB-PROCESS PAYMENT TO FMS ;6/8/94 2:17 PM
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 IF $DATA(PRC("SITE"))
IF PRC("SITE")]""
IF $DATA(^PRC(411,PRC("SITE"),0))
SET PRC("PARAM")=^(0)
+3 FOR I=0,1,2
SET P(I)=$GET(^PRCF(421.5,PRCF("CIDA"),I))
+4 SET PRCFX(1,"~")="FMS PAYMENT VOUCHER"
SET PRCFX(1.5,"Invoice ID#: ~?48")=$PIECE(P(0),"^")
+5 SET X=$PIECE(P(0),"^",27)
SET DD=421.5
SET F=.6
DO ^PRCFU1
SET PRCFX(2,"Certification Required? ~!!")=$SELECT(%:Y,1:"")
+6 ;S PRCFX(3,"Document Locator Number: ~?38")=$P(P(0),"^",2)
+7 SET PRCFX(4,"Invoice Number: ")=$PIECE(P(0),"^",3)
+8 SET Y=$PIECE(P(0),"^",4)
DO D^PRCFQ
SET PRCFX(5,"Date of Invoice: ~?38")=Y
+9 SET Y=$PIECE(P(0),"^",5)
DO D^PRCFQ
SET PRCFX(5.5,"Date Invoice Received: ")=Y
+10 SET Y=$PIECE(P(0),"^",21)
DO D^PRCFQ
SET PRCFX(5.7,"Date Goods/Services Received: ~?48")=Y
+11 SET X=$PIECE(P(0),"^",6)
SET DD=421.5
SET F=4
DO ^PRCFU1
SET PRCFX(5.8,"Invoice Type: ~!")=$SELECT(%:Y,1:"")
+12 SET XX=$PIECE(P(0),"^",8)
SET PRCFX(6,"Vendor: ~!!")=$SELECT(+XX=0:"",'$DATA(^PRC(440,XX,0))#2:"",1:$PIECE(^(0),"^"))
KILL XX
+13 SET PRCFX(7,"FMS Vendor ID#: ~!")=$PIECE(P(0),"^",10)
+14 ;S PRCFX(8,"Vendor Stub Name: ")=$P(P(0),"^",9)
+15 SET PRCFX(9,"Total Payment: $ ~!!")=$JUSTIFY($PIECE(P(0),"^",15)/100,0,2)
+16 SET PRCFX(10,"Shipping: $ ")=$JUSTIFY($PIECE(P(0),"^",14)/100,0,2)
+17 SET PRCFX(11,"Discount %: ~!")=$SELECT(+$PIECE(P(0),"^",11)=0:"NET "_$PIECE(P(1),"^",10),1:+$PIECE(P(0),"^",11)_"% "_$PIECE(P(0),"^",12)_" Days, NET "_$PIECE(P(1),"^",10))
+18 if $PIECE(P(0),"^",26)]""
SET PRCFX(11.5,"Discount Amount: ")=$JUSTIFY($PIECE(P(0),"^",26),0,2)
+19 ;S X=$P(P(0),"^",23),DD=421.5,F=20 D ^PRCFU1 S PRCFX(19,"Interest Indicator: ~!!")=$S(%:Y,1:"")
+20 ;S X=$P(P(0),"^",22),DD=421.5,F=19 D ^PRCFU1 S PRCFX(20,"Money Management Status: ")=$S(%:Y,1:"")
+21 SET X=$PIECE(P(0),"^",16)
SET DD=421.5
SET F=14
DO ^PRCFU1
SET PRCFX(14,"Liquidation Code: ~!")=$SELECT(%:Y,1:"")
+22 SET PRCFX(15,"BOC #1: ~!")=$PIECE(P(0),"^",17)
SET PRCFX(16,"Liquidation Amt #1: $ ~?38")=$JUSTIFY($PIECE(P(0),"^",19)/100,0,2)
+23 SET PRCFX(17,"BOC #2: ~!")=$PIECE(P(0),"^",18)
SET PRCFX(18,"Liquidation Amt #2: $ ~?38")=$JUSTIFY($PIECE(P(0),"^",20)/100,0,2)
+24 DO ^PRCFSCR
SET %A="Are you ready to release this invoice to FMS"
SET %B=""
SET %=1
DO ^PRCFYN
+25 IF %'=1
SET X=" <Action Terminated>*"
DO MSG^PRCFQ
GOTO OUT
+26 SET PRCFA("TTF")="900.00"
SET PRCFASYS="CAP"
DO TT^PRCFAC
+27 IF %'=1
SET X="Unable to select CAPPS transaction type 900.00. Please try again."
DO MSG^PRCFQ
GOTO OUT
+28 IF ^PRCF(421.5,PRCF("CIDA"),2)
IF $PIECE($PIECE(^(2),"^",3),"-",2)]""
SET PRCFA("REF")=$PIECE($PIECE(^(2),"^",3),"-",2)
+29 DO NEWCS^PRCFAC
IF '$DATA(DA)
SET X="No new FMS document created - Files inaccessible at this time.*"
DO MSG^PRCFQ
GOTO OUT
+30 SET X="Transferring invoice data to CAPPS transmittal document.*"
DO MSG^PRCFQ
+31 KILL F,T
FOR I=0,1,2
SET F(I)=$SELECT($DATA(^PRCF(421.5,PRCF("CIDA"),I)):^(I),1:"")
+32 FOR I=0,1,6,100
SET T(I)=$SELECT($DATA(^PRCF(423,PRCFA("CSDA"),I)):^(I),1:"")
+33 SET $PIECE(T(100),"^",1,6)="C^"_$PIECE(F(0),"^",2,6)
+34 SET $PIECE(T(100),"^",11,16)=$PIECE(F(0),"^",11,16)
+35 SET $PIECE(T(100),"^",17,23)=$PIECE(F(0),"^",17,23)
+36 FOR I=16,17,18
SET $PIECE(T(100),"^",I+12)=$PIECE(F(1),"^",I)
+37 SET $PIECE(T(1),"^",18)=$PIECE(F(0),"^",9)
SET $PIECE(T(6),"^",7)=$PIECE(F(0),"^",10)
SET $PIECE(T(100),"^",27)=$PIECE(F(0),"^",26)
+38 SET $PIECE(T(1),"^",8)=$PIECE(F(0),"^",17)
SET $PIECE(T(1),"^",10)=$PIECE(F(0),"^",18)
+39 SET $PIECE(T(100),"^",26)=$PIECE(F(2),"^",2)
SET $PIECE(T(1),"^",16)="~"
+40 FOR I=0,1,6,100
SET ^PRCF(423,PRCFA("CSDA"),I)=T(I)
+41 KILL F,T
SET PRCF("OUT")=""
+42 SET PRCFA("PAYMENT")=""
DO ^PRCFACXM
KILL PRCFA("PAYMENT")
+43 IF $DATA(PRCFDEL)!$DATA(PRCFA("CSHOLD"))
SET X="Transmittal document was "_$SELECT($DATA(PRCFDEL):"DELETED",1:"NOT TRANSMITTED")_". All further action on this invoice is suspended.*"
+44 IF $TEST
DO MSG^PRCFQ
KILL PRCFDEL,PRCFA("CSHOLD")
SET X=$PIECE(^PRCF(421.5,PRCF("CIDA"),2),"^")
IF 1
+45 IF '$TEST
Begin DoDot:1
+46 SET DA=PRCF("CIDA")
SET MESSAGE=""
+47 DO REMOVE^PRCFDES2(DA)
DO ENCODE^PRCFDES2(DA,DUZ,.MESSAGE)
+48 KILL MESSAGE
SET X=20
+49 QUIT
End DoDot:1
+50 KILL PRCF("OUT")
DO STATUS^PRCFDE1
X DO OUT^PRCFDE
KILL PRCFASYS
GOTO ^PRCFDA
OUT DO OUT^PRCFDE
KILL PRCFASYS
QUIT
