PRCABPF ;SF-ISC/YJK-PRINT BILL FORMS ;7/22/93 1:40 PM
V ;;4.5;Accounts Receivable;**99**;Mar 20, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
;Print the new bills generated by services - 1114,1080,1081.
OPENDV K POP S %ZIS="QM" D ^%ZIS Q:POP I IO=IO("0") W:$D(IOF) @IOF D @PRCARN,^%ZISC Q
I $D(IO("Q")) K IO("Q") S ZTRTN=PRCARN D ^%ZTLOAD,^%ZISC K ZTSAVE,ZTRTN,ZTDTH Q
U IO D @PRCARN D ^%ZISC K %ZIS Q
EN2 ;Print 1080 and 1081.
S PRCARN="EN21^PRCABPF" K ZTSAVE D OPENDV K PRCARN,ZTRTN Q
EN21 S PRCANEWB=+$O(^PRCA(430.3,"AC",104,0)) Q:PRCANEWB'>0 D EN
S PRCANEWB=+$O(^PRCA(430.3,"AC",110,0)) Q:PRCANEWB'>0 S PRCAMEND="" D EN Q
EN S PRCABPF=0
F PRCAK=0:0 S PRCABPF=$O(^PRCA(430,"AC",PRCANEWB,PRCABPF)) Q:PRCABPF="" S BT=+$G(^PRCA(430,PRCABPF,100)) I BT=1!(BT=2) S D0=PRCABPF,PRCAROUT="^PRCABP"_BT D @PRCAROUT
D KILLV Q
KILLV ;
END K BT,PRCAMEND,PRCANEWB,PRCA,PRCAK,PRCABPF,PRCAROUT Q
EN3 ;reprint 1080 and 1081.
NEW BT,DIC,PRCABN,PRCA,PRCATY,ST,ZTSAVE,PRCARN,ZTRTN
S DIC="^PRCA(430,",DIC(0)="AEQM",DIC("S")="S ST=+$P(^(0),U,8),BT=+$G(^(100)) I (BT=1!(BT=2)),ST>0,$D(^PRCA(430.3,ST,0)),$P(^(0),U,3)<200"
D BILLN^PRCAUTL G:'$D(PRCABN) EX
S D0=PRCABN,PRCARN="^PRCABP"_+^PRCA(430,D0,100) K ZTSAVE S ZTSAVE("D0")="" D OPENDV
EX Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCABPF 1290 printed Dec 13, 2024@01:39:09 Page 2
PRCABPF ;SF-ISC/YJK-PRINT BILL FORMS ;7/22/93 1:40 PM
V ;;4.5;Accounts Receivable;**99**;Mar 20, 1995
+1 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;Print the new bills generated by services - 1114,1080,1081.
OPENDV KILL POP
SET %ZIS="QM"
DO ^%ZIS
if POP
QUIT
IF IO=IO("0")
if $DATA(IOF)
WRITE @IOF
DO @PRCARN
DO ^%ZISC
QUIT
+1 IF $DATA(IO("Q"))
KILL IO("Q")
SET ZTRTN=PRCARN
DO ^%ZTLOAD
DO ^%ZISC
KILL ZTSAVE,ZTRTN,ZTDTH
QUIT
+2 USE IO
DO @PRCARN
DO ^%ZISC
KILL %ZIS
QUIT
EN2 ;Print 1080 and 1081.
+1 SET PRCARN="EN21^PRCABPF"
KILL ZTSAVE
DO OPENDV
KILL PRCARN,ZTRTN
QUIT
EN21 SET PRCANEWB=+$ORDER(^PRCA(430.3,"AC",104,0))
if PRCANEWB'>0
QUIT
DO EN
+1 SET PRCANEWB=+$ORDER(^PRCA(430.3,"AC",110,0))
if PRCANEWB'>0
QUIT
SET PRCAMEND=""
DO EN
QUIT
EN SET PRCABPF=0
+1 FOR PRCAK=0:0
SET PRCABPF=$ORDER(^PRCA(430,"AC",PRCANEWB,PRCABPF))
if PRCABPF=""
QUIT
SET BT=+$GET(^PRCA(430,PRCABPF,100))
IF BT=1!(BT=2)
SET D0=PRCABPF
SET PRCAROUT="^PRCABP"_BT
DO @PRCAROUT
+2 DO KILLV
QUIT
KILLV ;
END KILL BT,PRCAMEND,PRCANEWB,PRCA,PRCAK,PRCABPF,PRCAROUT
QUIT
EN3 ;reprint 1080 and 1081.
+1 NEW BT,DIC,PRCABN,PRCA,PRCATY,ST,ZTSAVE,PRCARN,ZTRTN
+2 SET DIC="^PRCA(430,"
SET DIC(0)="AEQM"
SET DIC("S")="S ST=+$P(^(0),U,8),BT=+$G(^(100)) I (BT=1!(BT=2)),ST>0,$D(^PRCA(430.3,ST,0)),$P(^(0),U,3)<200"
+3 DO BILLN^PRCAUTL
if '$DATA(PRCABN)
GOTO EX
+4 SET D0=PRCABN
SET PRCARN="^PRCABP"_+^PRCA(430,D0,100)
KILL ZTSAVE
SET ZTSAVE("D0")=""
DO OPENDV
EX QUIT
