PRCFDSUS ;WISC@ALTOONA/CTB-SUSPENSION LETTER ;7/12/94 8:31 AM
V ;;5.1;IFCAP;;Oct 20, 2000
;Per VHA Directive 10-93-142, this routine should not be modified.
;GENERATES SUSPENSION LETTER TO PRINTER IN PRCFD("PRINTER") (OPTIONAL)
;REQUIRES VARIABLE PRCF("CIDA")=INTERNAL NUMBER IN FILE 421.5
S ZTSAVE("PRCF(""CIDA"")")="",ZTSAVE("PRCF(""CHECK"")")=""
S ZTDESC="PAYMENT SUSPENSION LETTER",ZTRTN="DQ^PRCFDSUS"
I $P($G(^PRCF(421.5,PRCF("CIDA"),0)),U,8)="" D VENED^PRCFDCI
S:$D(PRCFD("PRINTER")) ZTIO=PRCFD("PRINTER") D ^PRCFQ Q
DQ D:$D(ZTQUEUED) KILL^%ZTLOAD
N I,N,X,Y,Z I '$G(PRCF("CIDA")) S ERR=1 G ERR
I $P($G(^PRCF(421.5,PRCF("CIDA"),0)),U,8)="" S ERR=2 G ERR
S PRVEN=$P(^PRCF(421.5,PRCF("CIDA"),0),"^",8)
I '$D(^PRC(440,PRVEN,0)) S ERR=3 G ERR
I '$D(^PRC(440,PRVEN,7)) S ERR=4 G ERR
S PRVEN(0)=^PRC(440,PRVEN,7),PRVEN=PRVEN_"^"_$P(^PRC(440,PRVEN,0),"^")
S %=0 F I=7,8,9 I $P(PRVEN(0),"^",I)="" S %=1 Q
I % S ERR=4 G ERR
I IOM<80!(IOM>102) S ERR=5 G ERR
S DIWL=$S(IOM=80:10,1:12),DIWR=$S(IOM=80:70,1:84),PRCTR=DIWR-DIWL\2
D NOW^PRCFQ W @IOF,!!!,?(DIWR-$L(Y)-1),Y,!!!!!!!!!!
W ?DIWL S X=$P(PRVEN,"^",2) D LC W X
F I=3,4,5,6 I $P(PRVEN(0),"^",I)]"" S X=$P(PRVEN(0),"^",I) D LC W !?DIWL,X
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
W !! I $P(PRVEN(0),"^")]"" W ?DIWL,"ATTN: " S X=$P(PRVEN(0),"^") D LC W X
W !! S DIWF="W"
F I=0,1 S PRCI(I)=^PRCF(421.5,PRCF("CIDA"),I)
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
S X=$P(PRCI(1),"^",8)-$P(PRCI(0),"^",15)/100,X2="2$" D COMMA^%DTC S PRCDED=X
S X="Your recent claim voucher - Invoice Number "_PRCINV_" - has been "
I PRCF("CHECK") S X=X_"approved, and a check will be forwarded promptly."
E S X=X_"disapproved and no check will be issued."
D DIWP^PRCUTL($G(DA)),^DIWW W !
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 !
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
W ! S $P(LINE,"_",DIWR-DIWL+1)="" W ?DIWL,LINE
W !?DIWL,"Amount Claimed: ",?(PRCTR-2),"| Amount Deducted: ",?(PRCTR+21),"| Amount Approved:",!,?(PRCTR-2),"|",?(PRCTR+21),"|",!?DIWL,PRCCLAIM,?(PRCTR-2),"| ",PRCDED,?(PRCTR+21),"| ",PRCPAID
;F I=$X:-1:1 W @IOBS
W !?DIWL,LINE,!!!
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))
D ^DIWW W !!?DIWL,"Sincerely,",!!!!
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
D ADDR S $P(^PRCF(421.5,PRCF("CIDA"),1),"^",4)=DT
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
ADDR Q:N="" S ADD=^PRC(411,$P(PRCI(1),"^",2),4,N,0)
F I=1:1:4 S X=$P(ADD,"^",I) I X]"" S Y="" D VA D:Y="" LC W !?DIWL,X
S X=$P(ADD,"^",5) D LC S Y=X,X=$P(^DIC(5,$P(ADD,"^",6),0),"^") D LC
S Y=Y_", "_X_" "_$P(ADD,"^",7) W !?DIWL,Y
Q
VA I "VAMC"[$P(X," ") S Y=$P(X," "),X=$P(X," ",2,99) D LC S X=Y_" "_X
Q
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)
Q
ERR ;
W !,"CERTIFIED INVOICE SUSPENSION LETTER ERROR REPORT",!!
I ERR>1 W !?2,"Invoice Tracking ID # ",PRCF("CIDA"),":",!
W !?2,$P($T(E+ERR),";",3),"."
W !!! G OUT
E ;
;;No Invoice Tracking ID # - could not locate Invoice record
;;The Vendor has not been identified in this Invoice Tracking record
;;The Vendor record is missing or incorrectly identified in the Vendor file
;;The Vendor payment address is missing or incomplete
;;Printer right margin should be set between 80 and 102 for Suspension Letter
;;PRINTER MARGIN INAPPROPRIATE FOR SUSPENSION LETTER, RIGHT MARGIN SHOULD BE BETWEEN 80 AND 102 CHARACTERS
REP ;REPRINT SUSPENSION LETTER
S PRCFD("PAY")="",DIC=421.5,DIC(0)="AEMNZ",DIC("S")="I $P(^(0),U,3)]"""""
D ^DIC K DIC I Y<0 K PRCFD Q
S PRCF("CIDA")=+Y,DIE="^PRCF(421.5,",DR="25//YES;23",DA=PRCF("CIDA") D ^DIE
I $P($G(^PRCF(421.5,PRCF("CIDA"),0)),U,15) S PRCF("CHECK")=1 G RP
S %A(1)=" The Invoice Tracking record for this claim voucher does not show"
S %A(2)=" an amount approved for payment. Does this mean that the claim voucher"
S %A(3)=" has been disapproved and that no check will be issued",%=2,%A=" ",B=""
D ^PRCFYN G ROUT:%<0 S PRCF("CHECK")=$S(%=1:0,1:1)
RP S %A="Are you ready to print the letter",%B="",%=1 D ^PRCFYN
ROUT I %'=1 S X=" Option Terminated.*" D MSG^PRCFQ G OUT^PRCFDE
D V G REP
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCFDSUS 4904 printed Dec 13, 2024@02:03:16 Page 2
PRCFDSUS ;WISC@ALTOONA/CTB-SUSPENSION LETTER ;7/12/94 8:31 AM
V ;;5.1;IFCAP;;Oct 20, 2000
+1 ;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;GENERATES SUSPENSION LETTER TO PRINTER IN PRCFD("PRINTER") (OPTIONAL)
+3 ;REQUIRES VARIABLE PRCF("CIDA")=INTERNAL NUMBER IN FILE 421.5
+4 SET ZTSAVE("PRCF(""CIDA"")")=""
SET ZTSAVE("PRCF(""CHECK"")")=""
+5 SET ZTDESC="PAYMENT SUSPENSION LETTER"
SET ZTRTN="DQ^PRCFDSUS"
+6 IF $PIECE($GET(^PRCF(421.5,PRCF("CIDA"),0)),U,8)=""
DO VENED^PRCFDCI
+7 if $DATA(PRCFD("PRINTER"))
SET ZTIO=PRCFD("PRINTER")
DO ^PRCFQ
QUIT
DQ if $DATA(ZTQUEUED)
DO KILL^%ZTLOAD
+1 NEW I,N,X,Y,Z
IF '$GET(PRCF("CIDA"))
SET ERR=1
GOTO ERR
+2 IF $PIECE($GET(^PRCF(421.5,PRCF("CIDA"),0)),U,8)=""
SET ERR=2
GOTO ERR
+3 SET PRVEN=$PIECE(^PRCF(421.5,PRCF("CIDA"),0),"^",8)
+4 IF '$DATA(^PRC(440,PRVEN,0))
SET ERR=3
GOTO ERR
+5 IF '$DATA(^PRC(440,PRVEN,7))
SET ERR=4
GOTO ERR
+6 SET PRVEN(0)=^PRC(440,PRVEN,7)
SET PRVEN=PRVEN_"^"_$PIECE(^PRC(440,PRVEN,0),"^")
+7 SET %=0
FOR I=7,8,9
IF $PIECE(PRVEN(0),"^",I)=""
SET %=1
QUIT
+8 IF %
SET ERR=4
GOTO ERR
+9 IF IOM<80!(IOM>102)
SET ERR=5
GOTO ERR
+10 SET DIWL=$SELECT(IOM=80:10,1:12)
SET DIWR=$SELECT(IOM=80:70,1:84)
SET PRCTR=DIWR-DIWL\2
+11 DO NOW^PRCFQ
WRITE @IOF,!!!,?(DIWR-$LENGTH(Y)-1),Y,!!!!!!!!!!
+12 WRITE ?DIWL
SET X=$PIECE(PRVEN,"^",2)
DO LC
WRITE X
+13 FOR I=3,4,5,6
IF $PIECE(PRVEN(0),"^",I)]""
SET X=$PIECE(PRVEN(0),"^",I)
DO LC
WRITE !?DIWL,X
+14 WRITE !?DIWL
SET X=$PIECE(PRVEN(0),"^",7)
DO LC
SET Y=X_", "
SET X=$PIECE(^DIC(5,$PIECE(PRVEN(0),"^",8),0),"^")
DO LC
SET Y=Y_X_" "_$PIECE(PRVEN(0),"^",9)
WRITE Y
KILL X,Y
+15 WRITE !!
IF $PIECE(PRVEN(0),"^")]""
WRITE ?DIWL,"ATTN: "
SET X=$PIECE(PRVEN(0),"^")
DO LC
WRITE X
+16 WRITE !!
SET DIWF="W"
+17 FOR I=0,1
SET PRCI(I)=^PRCF(421.5,PRCF("CIDA"),I)
+18 SET PRCINV=$PIECE(PRCI(0),"^",3)
SET X=$PIECE(PRCI(0),"^",15)/100
SET X2="2$"
DO COMMA^%DTC
SET PRCPAID=X
SET X=$PIECE(PRCI(1),"^",8)/100
SET X2="2$"
DO COMMA^%DTC
SET PRCCLAIM=X
+19 SET X=$PIECE(PRCI(1),"^",8)-$PIECE(PRCI(0),"^",15)/100
SET X2="2$"
DO COMMA^%DTC
SET PRCDED=X
+20 SET X="Your recent claim voucher - Invoice Number "_PRCINV_" - has been "
+21 IF PRCF("CHECK")
SET X=X_"approved, and a check will be forwarded promptly."
+22 IF '$TEST
SET X=X_"disapproved and no check will be issued."
+23 DO DIWP^PRCUTL($GET(DA))
DO ^DIWW
WRITE !
+24 SET 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."
DO DIWP^PRCUTL($GET(DA))
DO ^DIWW
WRITE !
+25 SET 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."
DO DIWP^PRCUTL($GET(DA))
DO ^DIWW
+26 WRITE !
SET $PIECE(LINE,"_",DIWR-DIWL+1)=""
WRITE ?DIWL,LINE
+27 WRITE !?DIWL,"Amount Claimed: ",?(PRCTR-2),"| Amount Deducted: ",?(PRCTR+21),"| Amount Approved:",!,?(PRCTR-2),"|",?(PRCTR+21),"|",!?DIWL,PRCCLAIM,?(PRCTR-2),"| ",PRCDED,?(PRCTR+21),"| ",PRCPAID
+28 ;F I=$X:-1:1 W @IOBS
+29 WRITE !?DIWL,LINE,!!!
+30 FOR PRCX=0:0
SET PRCX=$ORDER(^PRCF(421.5,PRCF("CIDA"),4,PRCX))
if PRCX=""
QUIT
SET X=$SELECT($DATA(^(PRCX,0)):^(0),1:"")
DO DIWP^PRCUTL($GET(DA))
+31 DO ^DIWW
WRITE !!?DIWL,"Sincerely,",!!!!
+32 SET N=""
FOR I=1:1
SET N=$ORDER(^PRC(411,$PIECE(PRCI(1),"^",2),4,"B",N))
if N=""
QUIT
IF N["FISCAL"
SET N=$ORDER(^(N,0))
QUIT
+33 DO ADDR
SET $PIECE(^PRCF(421.5,PRCF("CIDA"),1),"^",4)=DT
OUT KILL ADD,DIW,DIWF,DIWL,DIRW,DIWT,DN,ERR,PRCCLAIM,PRCDED,PRCF("CHECK"),PRCI,PRCINV,PRCTR,PRCX,PRIOP,PRVEN,X2,Z,ZTDESC,ZTRTN,ZTSAVE
QUIT
ADDR if N=""
QUIT
SET ADD=^PRC(411,$PIECE(PRCI(1),"^",2),4,N,0)
+1 FOR I=1:1:4
SET X=$PIECE(ADD,"^",I)
IF X]""
SET Y=""
DO VA
if Y=""
DO LC
WRITE !?DIWL,X
+2 SET X=$PIECE(ADD,"^",5)
DO LC
SET Y=X
SET X=$PIECE(^DIC(5,$PIECE(ADD,"^",6),0),"^")
DO LC
+3 SET Y=Y_", "_X_" "_$PIECE(ADD,"^",7)
WRITE !?DIWL,Y
+4 QUIT
VA IF "VAMC"[$PIECE(X," ")
SET Y=$PIECE(X," ")
SET X=$PIECE(X," ",2,99)
DO LC
SET X=Y_" "_X
+1 QUIT
LC FOR %=2:1:$LENGTH(X)
IF $EXTRACT(X,%)?1U
IF $EXTRACT(X,%-1)?1A
SET X=$EXTRACT(X,0,%-1)_$CHAR($ASCII(X,%)+32)_$EXTRACT(X,%+1,999)
+1 QUIT
ERR ;
+1 WRITE !,"CERTIFIED INVOICE SUSPENSION LETTER ERROR REPORT",!!
+2 IF ERR>1
WRITE !?2,"Invoice Tracking ID # ",PRCF("CIDA"),":",!
+3 WRITE !?2,$PIECE($TEXT(E+ERR),";",3),"."
+4 WRITE !!!
GOTO OUT
E ;
+1 ;;No Invoice Tracking ID # - could not locate Invoice record
+2 ;;The Vendor has not been identified in this Invoice Tracking record
+3 ;;The Vendor record is missing or incorrectly identified in the Vendor file
+4 ;;The Vendor payment address is missing or incomplete
+5 ;;Printer right margin should be set between 80 and 102 for Suspension Letter
+6 ;;PRINTER MARGIN INAPPROPRIATE FOR SUSPENSION LETTER, RIGHT MARGIN SHOULD BE BETWEEN 80 AND 102 CHARACTERS
REP ;REPRINT SUSPENSION LETTER
+1 SET PRCFD("PAY")=""
SET DIC=421.5
SET DIC(0)="AEMNZ"
SET DIC("S")="I $P(^(0),U,3)]"""""
+2 DO ^DIC
KILL DIC
IF Y<0
KILL PRCFD
QUIT
+3 SET PRCF("CIDA")=+Y
SET DIE="^PRCF(421.5,"
SET DR="25//YES;23"
SET DA=PRCF("CIDA")
DO ^DIE
+4 IF $PIECE($GET(^PRCF(421.5,PRCF("CIDA"),0)),U,15)
SET PRCF("CHECK")=1
GOTO RP
+5 SET %A(1)=" The Invoice Tracking record for this claim voucher does not show"
+6 SET %A(2)=" an amount approved for payment. Does this mean that the claim voucher"
+7 SET %A(3)=" has been disapproved and that no check will be issued"
SET %=2
SET %A=" "
SET B=""
+8 DO ^PRCFYN
if %<0
GOTO ROUT
SET PRCF("CHECK")=$SELECT(%=1:0,1:1)
RP SET %A="Are you ready to print the letter"
SET %B=""
SET %=1
DO ^PRCFYN
ROUT IF %'=1
SET X=" Option Terminated.*"
DO MSG^PRCFQ
GOTO OUT^PRCFDE
+1 DO V
GOTO REP
