- 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 Mar 13, 2025@21:07:33 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
