- 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 Feb 18, 2025@23:29:39 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