- PRCACM ;WASH-ISC@ALTOONA,PA/RGY-COMMENT ADJUSTMENT TRANSACTION ;6/2/95 2:41 PM
- ;;4.5;Accounts Receivable;**8,67,125,169,254,315**;Mar 20, 1995;Build 67
- ;;Per VA Directive 6402, this routine should not be modified.
- ;DBIA 3820-A used for direct global read into file 399.
- ;
- ;This is a routine for adjustment transaction.
- NEW PRCAEN,PRCAA1,DR,DIE,DA,D0,PRCAD,RCASK,PRCAA2,DIROUT,DIRUT,DIR,DUOUT,PRCA,PRCATY
- I '$G(GOTBILL) N PRCABN
- ADJUST 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 G:$D(DTOUT)!($G(GOTBILL)) Q G ADJUST
- 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 G ADJUST
- 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 G ADJUST
- 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
- I $G(GOTBILL) G Q ; PRCA*4.5*315
- G ADJUST
- 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,PRCAEN,PRCA("CKSITE"),PRCAIBS
- I '$G(GOTBILL) D BILL^PRCAUTL Q:('$D(PRCABN)) ;PRCA*4.5*315
- S PRCAIBS=$P($G(^DGCR(399,PRCABN,0)),U,13) ; IB claim status - DBIA3820-A
- I PRCAIBS=1 W !!,"** You cannot add AR Comments to an Entered/Not Reviewed claim. **",!,*7 Q:$G(GOTBILL) G BEGIN
- I PRCAIBS=2 W !!,"** You cannot add AR Comments to an MRA Request claim. **",!,*7 Q:$G(GOTBILL) G BEGIN
- I '$D(^PRCA(430,PRCABN,2,0)),PRCAIBS=7 W !!,"** You cannot add AR Comments to a claim Cancelled/not passed to AR. **",!,*7 Q:$G(GOTBILL) G BEGIN
- I $P($G(^PRCA(430,PRCABN,0)),"^",8)=49 W !!,"** Comments CANNOT be entered on an ARCHIVED bill. **",!,*7 Q:$G(GOTBILL) G BEGIN
- D SETTR^PRCAUTL,PATTR^PRCAUTL S DIC="^PRCA(433," K PRCAMT,PRCAD("DELETE") Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCACM 4383 printed Feb 18, 2025@23:05:37 Page 2
- PRCACM ;WASH-ISC@ALTOONA,PA/RGY-COMMENT ADJUSTMENT TRANSACTION ;6/2/95 2:41 PM
- +1 ;;4.5;Accounts Receivable;**8,67,125,169,254,315**;Mar 20, 1995;Build 67
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;DBIA 3820-A used for direct global read into file 399.
- +4 ;
- +5 ;This is a routine for adjustment transaction.
- +6 NEW PRCAEN,PRCAA1,DR,DIE,DA,D0,PRCAD,RCASK,PRCAA2,DIROUT,DIRUT,DIR,DUOUT,PRCA,PRCATY
- +7 IF '$GET(GOTBILL)
- NEW PRCABN
- ADJUST DO BEGIN
- if ('$DATA(PRCABN))!('$DATA(PRCAEN))
- GOTO Q
- +1 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
- if $DATA(DTOUT)!($GET(GOTBILL))
- GOTO Q
- GOTO ADJUST
- +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
- GOTO ADJUST
- 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
- GOTO ADJUST
- 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
- +9 ; PRCA*4.5*315
- IF $GET(GOTBILL)
- GOTO Q
- +10 GOTO ADJUST
- 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 ;
- +1 KILL PRCATERM,PRCAEN,PRCA("CKSITE"),PRCAIBS
- +2 ;PRCA*4.5*315
- IF '$GET(GOTBILL)
- DO BILL^PRCAUTL
- if ('$DATA(PRCABN))
- QUIT
- +3 ; IB claim status - DBIA3820-A
- SET PRCAIBS=$PIECE($GET(^DGCR(399,PRCABN,0)),U,13)
- +4 IF PRCAIBS=1
- WRITE !!,"** You cannot add AR Comments to an Entered/Not Reviewed claim. **",!,*7
- if $GET(GOTBILL)
- QUIT
- GOTO BEGIN
- +5 IF PRCAIBS=2
- WRITE !!,"** You cannot add AR Comments to an MRA Request claim. **",!,*7
- if $GET(GOTBILL)
- QUIT
- GOTO BEGIN
- +6 IF '$DATA(^PRCA(430,PRCABN,2,0))
- IF PRCAIBS=7
- WRITE !!,"** You cannot add AR Comments to a claim Cancelled/not passed to AR. **",!,*7
- if $GET(GOTBILL)
- QUIT
- GOTO BEGIN
- +7 IF $PIECE($GET(^PRCA(430,PRCABN,0)),"^",8)=49
- WRITE !!,"** Comments CANNOT be entered on an ARCHIVED bill. **",!,*7
- if $GET(GOTBILL)
- QUIT
- GOTO BEGIN
- +8 DO SETTR^PRCAUTL
- DO PATTR^PRCAUTL
- SET DIC="^PRCA(433,"
- KILL PRCAMT,PRCAD("DELETE")
- QUIT