RCJIBFN3 ;WASH-ISC@ALTOONA,PA/RGY-COMMENT ADJUSTMENT TRANSACTION ;10/5/95 4:36 PM
V ;;4.5;Accounts Receivable;**15,67,169**;Mar 20, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
;This is a routine for adjustment transaction.
ADJUST(PRCABN) ;Pass in the IFN for 430 - user allowed to add a brief comments as
;transaction in 433
N PRCAEN,PRCAA1,DR,DIE,DA,D0,PRCAD,RCASK,PRCAA2,DIROUT,DIRUT,DIR,DUOUT,PRCA,PRCATY
D BEGIN G:('$D(PRCABN))!('$D(PRCAEN)) Q
S PRCAA1=$S($D(^PRCA(433,PRCAEN,4,0)):+$P(^(0),U,4),1:0) G Q:PRCAA1'>0 S PRCAA2=$P(^(0),U,3) W !
DIE S DR="[PRCA COMMENT]",DIE="^PRCA(433,",DA=PRCAEN D ^DIE K DIE,DR,DA
I $P($G(^PRCA(433,PRCAEN,5)),"^",2)=""!'$P(^PRCA(433,PRCAEN,1),"^") S PRCACOMM="TRANSACTION INCOMPLETE" D DELETE^PRCAWO1 K PRCACOMM Q
W ! W:$D(IOF) @IOF S D0=PRCAEN K DXS D ^PRCATO4 K DXS
I $P($G(^PRCA(433,PRCAEN,1)),"^")>$P($G(^(5)),"^",3),$P($G(^(5)),"^",3) W !!,*7,"You entered a date of follow-up before the date of contact!" S PRCACOMM="INVALID FOLLOW-UP DATE" D DELETE^PRCAWO1 K PRCACOMM Q
ASK S %=2 W !!,"Is this correct" D YN^DICN I %=0 W !,"Answer 'Y' or 'YES' if this data is correct, answer 'N' or 'NO' if not",! G ASK
I (%<0)!(%=2) S PRCACOMM="USER CANCELED" D DELETE^PRCAWO1 K PRCACOMM Q
DONE I '$D(PRCAD("DELETE")) S RCASK=1 D TRANUP^PRCAUTL,UPPRIN^PRCADJ
I $P($G(^RCD(340,+$P(^PRCA(430,PRCABN,0),"^",9),0)),"^")[";DPT(" D
.S $P(^PRCA(433,PRCAEN,0),"^",10)=1
.S DIR(0)="Y",DIR("A")="Should the BRIEF COMMENT print on the patient statement",DIR("B")="NO" D ^DIR K DIR
.I Y=1 S DIR(0)="Y",DIR("A")="Are you SURE this BRIEF COMMENT should appear on the patient statement",DIR("B")="NO" D ^DIR K DIR I Y=1 D
..W !!,*7,"*** OK, This comment will appear on the patient's statement! ***",!,"(If you change your mind, use the option Remove/Add Comment From Patient Statement)",!
..S $P(^PRCA(433,PRCAEN,0),"^",10)=""
..Q
.Q
Q Q
EN1 Q:'$D(PRCABN)
NEW X
F X=0:0 S X=$O(^PRCA(433,"C",PRCABN,X)) Q:'X I $P($G(^PRCA(433,X,1)),"^",4) I $P(^(1),"^",2)=1!($P(^(1),"^",2)=35) S PRCAQNM=$P(^(1),"^",4)+1
Q
ASK1 ;ASK FOR STATUS
NEW DTOUT,DUOUT,DIRUT,DIR,DIROUT
S DIR("A")="Change 'BILL' status to?",DIR("B")="CANCELLED",DIR(0)="SB^1:CANCELLED;2:COLLECTED/CLOSED;" D ^DIR K DIR
I Y=2 S PRCA("STATUS")=$O(^PRCA(430.3,"AC",108,0))
Q
RPT ;
NEW %DT,BEG,END,DIC,L,FR,TO,FLDS,PRCACM,POP,PRCADEV
ST W !! S %DT="AEX",%DT("A")="Follow-up Date(s) From: " D ^%DT G:Y<0 REPQ S BEG=Y
S %DT="AEX",%DT("A")="Follow-up Date(s) To: " D ^%DT G:Y<0 REPQ S END=Y
I BEG>END W !!,*7," (Ending date must be greater than Start date.)" G ST
S %ZIS="MQ" D ^%ZIS G:POP REPQ S PRCADEV=ION_";"_IOST_";"_IOM_";"_IOSL_";"_$G(IO("DOC"))
I $D(IO("Q")) S Y=$$TI() G:Y<0 REPQ F PRCACM=1,2 S ZTDTH=$H,ZTRTN="DQ"_PRCACM_"^PRCACM",ZTSAVE("BEG")="",ZTSAVE("PRCADEV")="",ZTSAVE("END")="",ZTDESC="Comment Follow-up List" D ^%ZTLOAD G REPQ:PRCACM=2
D DQ1,DQ2:'$D(DTOUT)
REPQ Q
DQ1 ;
S IOP=PRCADEV,DIC="^PRCA(433,",L=0,BY="[PRCA FOLLOW-UP]",FLDS="[PRCA FOLLOW-UP]",FR=BEG,TO=END D EN1^DIP
D ^%ZISC K IOP
I $E(IOST)="C" W !,*7,"OK, first part of report complete...",!,"press return to continue: " R X:DTIME W @IOF S:X["^"!'$T DTOUT=1
Q
DQ2 ;
S IOP=PRCADEV D ^%ZIS
I 'POP S IOP=PRCADEV,DIC="^RC(341,",L=0,BY="[RCAM COMMENT]",FLDS="[RCAM COMMENT]",FR=BEG,TO=END D EN1^DIP
D ^%ZISC K IOP
Q
TI() ;
N %DT D NOW^%DTC S %DT("A")="Request Time to Queue? ",%DT("B")="NOW"
S %DT="AERX",%DT(0)=% D ^%DT
Q Y
BEGIN ;K PRCATERM,PRCABN,PRCAEN,PRCA("CKSITE") D BILL^PRCAUTL Q:('$D(PRCABN))
I '$D(^PRCA(430,PRCABN,2,0)) W !!,"** This bill was cancelled in IB before it was passed to AR. **",!,*7 Q
I $P($G(^PRCA(430,PRCABN,0)),"^",8)=49 W !!,"** Comments CANNOT be entered on an ARCHIVED bill. **",!,*7 Q
D SETTR^PRCAUTL,PATTR^PRCAUTL S DIC="^PRCA(433," K PRCAMT,PRCAD("DELETE") Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCJIBFN3 3875 printed Nov 22, 2024@16:57:18 Page 2
RCJIBFN3 ;WASH-ISC@ALTOONA,PA/RGY-COMMENT ADJUSTMENT TRANSACTION ;10/5/95 4:36 PM
V ;;4.5;Accounts Receivable;**15,67,169**;Mar 20, 1995
+1 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+2 ;This is a routine for adjustment transaction.
ADJUST(PRCABN) ;Pass in the IFN for 430 - user allowed to add a brief comments as
+1 ;transaction in 433
+2 NEW PRCAEN,PRCAA1,DR,DIE,DA,D0,PRCAD,RCASK,PRCAA2,DIROUT,DIRUT,DIR,DUOUT,PRCA,PRCATY
+3 DO BEGIN
if ('$DATA(PRCABN))!('$DATA(PRCAEN))
GOTO Q
+4 SET PRCAA1=$SELECT($DATA(^PRCA(433,PRCAEN,4,0)):+$PIECE(^(0),U,4),1:0)
if PRCAA1'>0
GOTO Q
SET PRCAA2=$PIECE(^(0),U,3)
WRITE !
DIE SET DR="[PRCA COMMENT]"
SET DIE="^PRCA(433,"
SET DA=PRCAEN
DO ^DIE
KILL DIE,DR,DA
+1 IF $PIECE($GET(^PRCA(433,PRCAEN,5)),"^",2)=""!'$PIECE(^PRCA(433,PRCAEN,1),"^")
SET PRCACOMM="TRANSACTION INCOMPLETE"
DO DELETE^PRCAWO1
KILL PRCACOMM
QUIT
+2 WRITE !
if $DATA(IOF)
WRITE @IOF
SET D0=PRCAEN
KILL DXS
DO ^PRCATO4
KILL DXS
+3 IF $PIECE($GET(^PRCA(433,PRCAEN,1)),"^")>$PIECE($GET(^(5)),"^",3)
IF $PIECE($GET(^(5)),"^",3)
WRITE !!,*7,"You entered a date of follow-up before the date of contact!"
SET PRCACOMM="INVALID FOLLOW-UP DATE"
DO DELETE^PRCAWO1
KILL PRCACOMM
QUIT
ASK SET %=2
WRITE !!,"Is this correct"
DO YN^DICN
IF %=0
WRITE !,"Answer 'Y' or 'YES' if this data is correct, answer 'N' or 'NO' if not",!
GOTO ASK
+1 IF (%<0)!(%=2)
SET PRCACOMM="USER CANCELED"
DO DELETE^PRCAWO1
KILL PRCACOMM
QUIT
DONE IF '$DATA(PRCAD("DELETE"))
SET RCASK=1
DO TRANUP^PRCAUTL
DO UPPRIN^PRCADJ
+1 IF $PIECE($GET(^RCD(340,+$PIECE(^PRCA(430,PRCABN,0),"^",9),0)),"^")[";DPT("
Begin DoDot:1
+2 SET $PIECE(^PRCA(433,PRCAEN,0),"^",10)=1
+3 SET DIR(0)="Y"
SET DIR("A")="Should the BRIEF COMMENT print on the patient statement"
SET DIR("B")="NO"
DO ^DIR
KILL DIR
+4 IF Y=1
SET DIR(0)="Y"
SET DIR("A")="Are you SURE this BRIEF COMMENT should appear on the patient statement"
SET DIR("B")="NO"
DO ^DIR
KILL DIR
IF Y=1
Begin DoDot:2
+5 WRITE !!,*7,"*** OK, This comment will appear on the patient's statement! ***",!,"(If you change your mind, use the option Remove/Add Comment From Patient Statement)",!
+6 SET $PIECE(^PRCA(433,PRCAEN,0),"^",10)=""
+7 QUIT
End DoDot:2
+8 QUIT
End DoDot:1
Q QUIT
EN1 if '$DATA(PRCABN)
QUIT
+1 NEW X
+2 FOR X=0:0
SET X=$ORDER(^PRCA(433,"C",PRCABN,X))
if 'X
QUIT
IF $PIECE($GET(^PRCA(433,X,1)),"^",4)
IF $PIECE(^(1),"^",2)=1!($PIECE(^(1),"^",2)=35)
SET PRCAQNM=$PIECE(^(1),"^",4)+1
+3 QUIT
ASK1 ;ASK FOR STATUS
+1 NEW DTOUT,DUOUT,DIRUT,DIR,DIROUT
+2 SET DIR("A")="Change 'BILL' status to?"
SET DIR("B")="CANCELLED"
SET DIR(0)="SB^1:CANCELLED;2:COLLECTED/CLOSED;"
DO ^DIR
KILL DIR
+3 IF Y=2
SET PRCA("STATUS")=$ORDER(^PRCA(430.3,"AC",108,0))
+4 QUIT
RPT ;
+1 NEW %DT,BEG,END,DIC,L,FR,TO,FLDS,PRCACM,POP,PRCADEV
ST WRITE !!
SET %DT="AEX"
SET %DT("A")="Follow-up Date(s) From: "
DO ^%DT
if Y<0
GOTO REPQ
SET BEG=Y
+1 SET %DT="AEX"
SET %DT("A")="Follow-up Date(s) To: "
DO ^%DT
if Y<0
GOTO REPQ
SET END=Y
+2 IF BEG>END
WRITE !!,*7," (Ending date must be greater than Start date.)"
GOTO ST
+3 SET %ZIS="MQ"
DO ^%ZIS
if POP
GOTO REPQ
SET PRCADEV=ION_";"_IOST_";"_IOM_";"_IOSL_";"_$GET(IO("DOC"))
+4 IF $DATA(IO("Q"))
SET Y=$$TI()
if Y<0
GOTO REPQ
FOR PRCACM=1,2
SET ZTDTH=$HOROLOG
SET ZTRTN="DQ"_PRCACM_"^PRCACM"
SET ZTSAVE("BEG")=""
SET ZTSAVE("PRCADEV")=""
SET ZTSAVE("END")=""
SET ZTDESC="Comment Follow-up List"
DO ^%ZTLOAD
if PRCACM=2
GOTO REPQ
+5 DO DQ1
if '$DATA(DTOUT)
DO DQ2
REPQ QUIT
DQ1 ;
+1 SET IOP=PRCADEV
SET DIC="^PRCA(433,"
SET L=0
SET BY="[PRCA FOLLOW-UP]"
SET FLDS="[PRCA FOLLOW-UP]"
SET FR=BEG
SET TO=END
DO EN1^DIP
+2 DO ^%ZISC
KILL IOP
+3 IF $EXTRACT(IOST)="C"
WRITE !,*7,"OK, first part of report complete...",!,"press return to continue: "
READ X:DTIME
WRITE @IOF
if X["^"!'$TEST
SET DTOUT=1
+4 QUIT
DQ2 ;
+1 SET IOP=PRCADEV
DO ^%ZIS
+2 IF 'POP
SET IOP=PRCADEV
SET DIC="^RC(341,"
SET L=0
SET BY="[RCAM COMMENT]"
SET FLDS="[RCAM COMMENT]"
SET FR=BEG
SET TO=END
DO EN1^DIP
+3 DO ^%ZISC
KILL IOP
+4 QUIT
TI() ;
+1 NEW %DT
DO NOW^%DTC
SET %DT("A")="Request Time to Queue? "
SET %DT("B")="NOW"
+2 SET %DT="AERX"
SET %DT(0)=%
DO ^%DT
+3 QUIT Y
BEGIN ;K PRCATERM,PRCABN,PRCAEN,PRCA("CKSITE") D BILL^PRCAUTL Q:('$D(PRCABN))
+1 IF '$DATA(^PRCA(430,PRCABN,2,0))
WRITE !!,"** This bill was cancelled in IB before it was passed to AR. **",!,*7
QUIT
+2 IF $PIECE($GET(^PRCA(430,PRCABN,0)),"^",8)=49
WRITE !!,"** Comments CANNOT be entered on an ARCHIVED bill. **",!,*7
QUIT
+3 DO SETTR^PRCAUTL
DO PATTR^PRCAUTL
SET DIC="^PRCA(433,"
KILL PRCAMT,PRCAD("DELETE")
QUIT
