- 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 Jan 18, 2025@02:40:23 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