| 1 | PRCFDSUS ;WISC@ALTOONA/CTB-SUSPENSION LETTER ;7/12/94 8:31 AM
|
|---|
| 2 | V ;;5.1;IFCAP;;Oct 20, 2000
|
|---|
| 3 | ;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | ;GENERATES SUSPENSION LETTER TO PRINTER IN PRCFD("PRINTER") (OPTIONAL)
|
|---|
| 5 | ;REQUIRES VARIABLE PRCF("CIDA")=INTERNAL NUMBER IN FILE 421.5
|
|---|
| 6 | S ZTSAVE("PRCF(""CIDA"")")="",ZTSAVE("PRCF(""CHECK"")")=""
|
|---|
| 7 | S ZTDESC="PAYMENT SUSPENSION LETTER",ZTRTN="DQ^PRCFDSUS"
|
|---|
| 8 | I $P($G(^PRCF(421.5,PRCF("CIDA"),0)),U,8)="" D VENED^PRCFDCI
|
|---|
| 9 | S:$D(PRCFD("PRINTER")) ZTIO=PRCFD("PRINTER") D ^PRCFQ Q
|
|---|
| 10 | DQ D:$D(ZTQUEUED) KILL^%ZTLOAD
|
|---|
| 11 | N I,N,X,Y,Z I '$G(PRCF("CIDA")) S ERR=1 G ERR
|
|---|
| 12 | I $P($G(^PRCF(421.5,PRCF("CIDA"),0)),U,8)="" S ERR=2 G ERR
|
|---|
| 13 | S PRVEN=$P(^PRCF(421.5,PRCF("CIDA"),0),"^",8)
|
|---|
| 14 | I '$D(^PRC(440,PRVEN,0)) S ERR=3 G ERR
|
|---|
| 15 | I '$D(^PRC(440,PRVEN,7)) S ERR=4 G ERR
|
|---|
| 16 | S PRVEN(0)=^PRC(440,PRVEN,7),PRVEN=PRVEN_"^"_$P(^PRC(440,PRVEN,0),"^")
|
|---|
| 17 | S %=0 F I=7,8,9 I $P(PRVEN(0),"^",I)="" S %=1 Q
|
|---|
| 18 | I % S ERR=4 G ERR
|
|---|
| 19 | I IOM<80!(IOM>102) S ERR=5 G ERR
|
|---|
| 20 | S DIWL=$S(IOM=80:10,1:12),DIWR=$S(IOM=80:70,1:84),PRCTR=DIWR-DIWL\2
|
|---|
| 21 | D NOW^PRCFQ W @IOF,!!!,?(DIWR-$L(Y)-1),Y,!!!!!!!!!!
|
|---|
| 22 | W ?DIWL S X=$P(PRVEN,"^",2) D LC W X
|
|---|
| 23 | F I=3,4,5,6 I $P(PRVEN(0),"^",I)]"" S X=$P(PRVEN(0),"^",I) D LC W !?DIWL,X
|
|---|
| 24 | W !?DIWL S X=$P(PRVEN(0),"^",7) D LC S Y=X_", ",X=$P(^DIC(5,$P(PRVEN(0),"^",8),0),"^") D LC S Y=Y_X_" "_$P(PRVEN(0),"^",9) W Y K X,Y
|
|---|
| 25 | W !! I $P(PRVEN(0),"^")]"" W ?DIWL,"ATTN: " S X=$P(PRVEN(0),"^") D LC W X
|
|---|
| 26 | W !! S DIWF="W"
|
|---|
| 27 | F I=0,1 S PRCI(I)=^PRCF(421.5,PRCF("CIDA"),I)
|
|---|
| 28 | S PRCINV=$P(PRCI(0),"^",3),X=$P(PRCI(0),"^",15)/100,X2="2$" D COMMA^%DTC S PRCPAID=X,X=$P(PRCI(1),"^",8)/100,X2="2$" D COMMA^%DTC S PRCCLAIM=X
|
|---|
| 29 | S X=$P(PRCI(1),"^",8)-$P(PRCI(0),"^",15)/100,X2="2$" D COMMA^%DTC S PRCDED=X
|
|---|
| 30 | S X="Your recent claim voucher - Invoice Number "_PRCINV_" - has been "
|
|---|
| 31 | I PRCF("CHECK") S X=X_"approved, and a check will be forwarded promptly."
|
|---|
| 32 | E S X=X_"disapproved and no check will be issued."
|
|---|
| 33 | D DIWP^PRCUTL($G(DA)),^DIWW W !
|
|---|
| 34 | S X="As explained below it was necessary to make a deduction from the amount claimed. If a credit memo is issued to clear your accounting records of this overcharge, DO NOT send us a copy." D DIWP^PRCUTL($G(DA)),^DIWW W !
|
|---|
| 35 | S X="Should you submit a reclaim voucher, please return this letter with it and also enclose a supporting statement or additional evidence substantiating your claim." D DIWP^PRCUTL($G(DA)),^DIWW
|
|---|
| 36 | W ! S $P(LINE,"_",DIWR-DIWL+1)="" W ?DIWL,LINE
|
|---|
| 37 | W !?DIWL,"Amount Claimed: ",?(PRCTR-2),"| Amount Deducted: ",?(PRCTR+21),"| Amount Approved:",!,?(PRCTR-2),"|",?(PRCTR+21),"|",!?DIWL,PRCCLAIM,?(PRCTR-2),"| ",PRCDED,?(PRCTR+21),"| ",PRCPAID
|
|---|
| 38 | ;F I=$X:-1:1 W @IOBS
|
|---|
| 39 | W !?DIWL,LINE,!!!
|
|---|
| 40 | F PRCX=0:0 S PRCX=$O(^PRCF(421.5,PRCF("CIDA"),4,PRCX)) Q:PRCX="" S X=$S($D(^(PRCX,0)):^(0),1:"") D DIWP^PRCUTL($G(DA))
|
|---|
| 41 | D ^DIWW W !!?DIWL,"Sincerely,",!!!!
|
|---|
| 42 | S N="" F I=1:1 S N=$O(^PRC(411,$P(PRCI(1),"^",2),4,"B",N)) Q:N="" I N["FISCAL" S N=$O(^(N,0)) Q
|
|---|
| 43 | D ADDR S $P(^PRCF(421.5,PRCF("CIDA"),1),"^",4)=DT
|
|---|
| 44 | OUT K ADD,DIW,DIWF,DIWL,DIRW,DIWT,DN,ERR,PRCCLAIM,PRCDED,PRCF("CHECK"),PRCI,PRCINV,PRCTR,PRCX,PRIOP,PRVEN,X2,Z,ZTDESC,ZTRTN,ZTSAVE Q
|
|---|
| 45 | ADDR Q:N="" S ADD=^PRC(411,$P(PRCI(1),"^",2),4,N,0)
|
|---|
| 46 | F I=1:1:4 S X=$P(ADD,"^",I) I X]"" S Y="" D VA D:Y="" LC W !?DIWL,X
|
|---|
| 47 | S X=$P(ADD,"^",5) D LC S Y=X,X=$P(^DIC(5,$P(ADD,"^",6),0),"^") D LC
|
|---|
| 48 | S Y=Y_", "_X_" "_$P(ADD,"^",7) W !?DIWL,Y
|
|---|
| 49 | Q
|
|---|
| 50 | VA I "VAMC"[$P(X," ") S Y=$P(X," "),X=$P(X," ",2,99) D LC S X=Y_" "_X
|
|---|
| 51 | Q
|
|---|
| 52 | LC F %=2:1:$L(X) I $E(X,%)?1U,$E(X,%-1)?1A S X=$E(X,0,%-1)_$C($A(X,%)+32)_$E(X,%+1,999)
|
|---|
| 53 | Q
|
|---|
| 54 | ERR ;
|
|---|
| 55 | W !,"CERTIFIED INVOICE SUSPENSION LETTER ERROR REPORT",!!
|
|---|
| 56 | I ERR>1 W !?2,"Invoice Tracking ID # ",PRCF("CIDA"),":",!
|
|---|
| 57 | W !?2,$P($T(E+ERR),";",3),"."
|
|---|
| 58 | W !!! G OUT
|
|---|
| 59 | E ;
|
|---|
| 60 | ;;No Invoice Tracking ID # - could not locate Invoice record
|
|---|
| 61 | ;;The Vendor has not been identified in this Invoice Tracking record
|
|---|
| 62 | ;;The Vendor record is missing or incorrectly identified in the Vendor file
|
|---|
| 63 | ;;The Vendor payment address is missing or incomplete
|
|---|
| 64 | ;;Printer right margin should be set between 80 and 102 for Suspension Letter
|
|---|
| 65 | ;;PRINTER MARGIN INAPPROPRIATE FOR SUSPENSION LETTER, RIGHT MARGIN SHOULD BE BETWEEN 80 AND 102 CHARACTERS
|
|---|
| 66 | REP ;REPRINT SUSPENSION LETTER
|
|---|
| 67 | S PRCFD("PAY")="",DIC=421.5,DIC(0)="AEMNZ",DIC("S")="I $P(^(0),U,3)]"""""
|
|---|
| 68 | D ^DIC K DIC I Y<0 K PRCFD Q
|
|---|
| 69 | S PRCF("CIDA")=+Y,DIE="^PRCF(421.5,",DR="25//YES;23",DA=PRCF("CIDA") D ^DIE
|
|---|
| 70 | I $P($G(^PRCF(421.5,PRCF("CIDA"),0)),U,15) S PRCF("CHECK")=1 G RP
|
|---|
| 71 | S %A(1)=" The Invoice Tracking record for this claim voucher does not show"
|
|---|
| 72 | S %A(2)=" an amount approved for payment. Does this mean that the claim voucher"
|
|---|
| 73 | S %A(3)=" has been disapproved and that no check will be issued",%=2,%A=" ",B=""
|
|---|
| 74 | D ^PRCFYN G ROUT:%<0 S PRCF("CHECK")=$S(%=1:0,1:1)
|
|---|
| 75 | RP S %A="Are you ready to print the letter",%B="",%=1 D ^PRCFYN
|
|---|
| 76 | ROUT I %'=1 S X=" Option Terminated.*" D MSG^PRCFQ G OUT^PRCFDE
|
|---|
| 77 | D V G REP
|
|---|
