- PRCAEOL ;SF-ISC/YJK-EDIT INCOMPLETE OLD BILL ;2/28/95 10:35 AM
- V ;;4.5;Accounts Receivable;**67,153**;Mar 20, 1995
- ;;Per VHA Directive 10-93-142, this routine should not be modified.
- ;This edits incomplete old bill. The account is classified
- ;with category.
- ;
- ;===================== EDIT INCOMPLETE AR ===========================
- EDIN ;edit incomplete accounts receivable.
- D CKSITE^PRCAUDT G:'$D(PRCA("SITE")) END
- EN S DIC("S")="S Z0=$S($D(^PRCA(430.3,+$P(^(0),U,8),0)):$P(^(0),U,3),1:0) I Z0=106"
- D DIC^PRCAUDT G:'$D(PRCABN) END S PRCA("MESS1")="THE ACCOUNT IS STILL INCOMPLETE OLD BILL"
- K PRCADINO D EDT
- I $G(PRCABN)>0,$P(^PRCA(430,PRCABN,0),U,8)=$O(^PRCA(430.3,"AC",102,"")) D PREPAY^RCBEPAYP(PRCABN)
- D KILLV G EDIN
- EDT D DIE Q:PRCA("LOCK")=1 I $D(PRCADINO),($P(^PRCA(430,PRCABN,0),U,2)="")!($P(^(0),U,9)="") S PRCADEL=1 Q
- I $D(PRCADINO) W !!,*7,PRCA("MESS1"),!! Q
- D COMMENTS^PRCAUT3 G:$D(PRCA("EXIT")) DIP1
- DIP S PRCAT=+$P(^PRCA(430,PRCABN,0),U,2) D:$P(^PRCA(430.2,PRCAT,0),U,3)>0 SEGMT S PRCAT=$S($D(^PRCA(430.2,PRCAT,0)):$P(^(0),U,6),1:"") D DISPL S PRCAOK=0 D ASK1 G:$D(PRCA("EXIT")) DIP1
- I PRCAOK=1 G:'$D(PRCANM) DIP1 W !! D KILLV Q
- D ASK2 I PRCAOK=1 D DIE G DIP
- DIP1 W !!,PRCA("MESS1"),! S PRCA("STATUS")=$O(^PRCA(430.3,"AC",106,"")) D UPSTATS^PRCAUT2 K PRCA("STATUS") D KILLV Q ;end of EDIN
- KILLV L -^PRCA(430,+$G(PRCABN))
- K PRCADEL,DIC,DR,DIE,PRCAT,PRCAGLN,PRCA("CKSITE"),PRCADINO,PRCAOK,PRCA("MESS1"),PRCA("EXIT"),PRCA("MESS2"),PRCAT,PRCANM,PRCADEL,PRCATY Q
- END D KILLV K PRCABN,PRCAREF,PRCA Q
- ;======================= SUBROUTINES ================================
- DIE K PRCAT W ! S DA=PRCABN,DIC="^PRCA(430,",PRCA("LOCK")=0 D LOCKF^PRCAWO1 Q:PRCA("LOCK")=1 S DIE=DIC,DR="[PRCA CAT SET]" D ^DIE I +$P(^PRCA(430,PRCABN,0),U,2)'>0 S PRCADINO="" Q
- I '$$ACCK^PRCAACC(PRCABN) W !!,*7,"This catergory of bill CAN NOT be re-established.",! S PRCADINO="" Q
- S PRCAT=$P(^PRCA(430.2,+$P(^PRCA(430,PRCABN,0),U,2),0),U,6),PRCAGLN=$P(^(0),U,4) S:$P(^(0),U,7)=24 PRCAT("C")=1
- D1 S PRCAREF=1,DR="[PRCA OLD SET]" D ^DIE K DR
- I $P(^PRCA(430,PRCABN,0),U,9)'>0 W !,"Debtor input is not entered.",! S PRCADINO="" Q
- I +$P(^PRCA(430,PRCABN,0),U,5)'>0 W !,"'Bill Resulting From' input is not set.",! S PRCADINO="" Q
- Q
- DISPL ;display the accounts receivable data user has entered.
- Q:'$D(PRCABN) I '$D(IOF) S IOP="" D ^%ZIS
- S D0=PRCABN K ^UTILITY($J,"W") S PRCAIO=IO,PRCAIO(0)=IO(0) D PROC^PRCAPRO Q
- ASK2 S %=2 W !!,"DO YOU WANT TO EDIT THE DATA" D YN^DICN Q:(%<0)!(%=2)
- I %=0 W " ANSWER 'Y'(YES) OR 'N'(NO)" G ASK2
- S PRCAOK=1 Q
- ASK1 S %=2 W !!,"IS THIS DATA CORRECT" D YN^DICN I %<0 S PRCA("EXIT")="" Q
- I %=0 W " ANSWER 'Y'(YES) OR 'N'(NO)" G ASK1
- Q:%'=1 I $P(^PRCA(430,PRCABN,0),U,8)=$O(^PRCA(430.3,"AC",106,"")) W !,"This account has an 'OLD BILL' status and should be edited.",! S PRCAOLD="",DIE="^PRCA(430,",DA=PRCABN,DR="8" D ^DIE K DIE,DR,PRCAOLD
- I $P(^PRCA(430,PRCABN,0),U,8)=$O(^PRCA(430.3,"AC",106,"")) W !,"This account still has an 'OLD BILL' status." Q
- S $P(^PRCA(430,PRCABN,9),U,6)=$O(^PRCA(430.3,"AC",106,""))
- S PRCAOK=1,DA=PRCABN D SIG^PRCASIG,NOW^%DTC
- I $D(PRCANM) S $P(^PRCA(430,PRCABN,9),U,1,3)=+DUZ_U_PRCANM_U_%
- Q
- DELETE ;delete new AR which has no category and debtor field.
- S PRCACOMM="USER CANCELED" D DELETE^PRCABIL4 K PRCACOMM
- W *7,!,"The accounts receivable has been deleted!",! Q
- SEGMT ;save segment number in the file 430 for AMIS report.
- Q:'$D(PRCAT)!$P(^PRCA(430,PRCABN,0),"^",21) N PRCARI,Y
- S PRCARI=$O(^PRCA(430.2,"AC",21,0))
- I PRCAT=PRCARI S X=PRCABN D:$D(^DGCR(399,PRCABN)) ^IBCAMS S:'$D(^DGCR(399,PRCABN)) Y=297
- S:'$D(Y) Y=-1 S %=$S(PRCARI=PRCAT&(Y<1):"0",PRCARI=PRCAT:Y,$D(^PRCA(430.2,PRCAT,0)):$P(^(0),U,3),1:"0")
- I %=240 S %=$S($P(^PRCA(430,PRCABN,0),U,16)>0:$P(^PRCA(430.2,$P(^PRCA(430,PRCABN,0),U,16),0),U,3),1:%)
- S $P(^PRCA(430,PRCABN,0),U,21)=% K %,PRCARI,Y Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPRCAEOL 3894 printed Feb 18, 2025@23:05:49 Page 2
- PRCAEOL ;SF-ISC/YJK-EDIT INCOMPLETE OLD BILL ;2/28/95 10:35 AM
- V ;;4.5;Accounts Receivable;**67,153**;Mar 20, 1995
- +1 ;;Per VHA Directive 10-93-142, this routine should not be modified.
- +2 ;This edits incomplete old bill. The account is classified
- +3 ;with category.
- +4 ;
- +5 ;===================== EDIT INCOMPLETE AR ===========================
- EDIN ;edit incomplete accounts receivable.
- +1 DO CKSITE^PRCAUDT
- if '$DATA(PRCA("SITE"))
- GOTO END
- EN SET DIC("S")="S Z0=$S($D(^PRCA(430.3,+$P(^(0),U,8),0)):$P(^(0),U,3),1:0) I Z0=106"
- +1 DO DIC^PRCAUDT
- if '$DATA(PRCABN)
- GOTO END
- SET PRCA("MESS1")="THE ACCOUNT IS STILL INCOMPLETE OLD BILL"
- +2 KILL PRCADINO
- DO EDT
- +3 IF $GET(PRCABN)>0
- IF $PIECE(^PRCA(430,PRCABN,0),U,8)=$ORDER(^PRCA(430.3,"AC",102,""))
- DO PREPAY^RCBEPAYP(PRCABN)
- +4 DO KILLV
- GOTO EDIN
- EDT DO DIE
- if PRCA("LOCK")=1
- QUIT
- IF $DATA(PRCADINO)
- IF ($PIECE(^PRCA(430,PRCABN,0),U,2)="")!($PIECE(^(0),U,9)="")
- SET PRCADEL=1
- QUIT
- +1 IF $DATA(PRCADINO)
- WRITE !!,*7,PRCA("MESS1"),!!
- QUIT
- +2 DO COMMENTS^PRCAUT3
- if $DATA(PRCA("EXIT"))
- GOTO DIP1
- DIP SET PRCAT=+$PIECE(^PRCA(430,PRCABN,0),U,2)
- if $PIECE(^PRCA(430.2,PRCAT,0),U,3)>0
- DO SEGMT
- SET PRCAT=$SELECT($DATA(^PRCA(430.2,PRCAT,0)):$PIECE(^(0),U,6),1:"")
- DO DISPL
- SET PRCAOK=0
- DO ASK1
- if $DATA(PRCA("EXIT"))
- GOTO DIP1
- +1 IF PRCAOK=1
- if '$DATA(PRCANM)
- GOTO DIP1
- WRITE !!
- DO KILLV
- QUIT
- +2 DO ASK2
- IF PRCAOK=1
- DO DIE
- GOTO DIP
- DIP1 ;end of EDIN
- WRITE !!,PRCA("MESS1"),!
- SET PRCA("STATUS")=$ORDER(^PRCA(430.3,"AC",106,""))
- DO UPSTATS^PRCAUT2
- KILL PRCA("STATUS")
- DO KILLV
- QUIT
- KILLV LOCK -^PRCA(430,+$GET(PRCABN))
- +1 KILL PRCADEL,DIC,DR,DIE,PRCAT,PRCAGLN,PRCA("CKSITE"),PRCADINO,PRCAOK,PRCA("MESS1"),PRCA("EXIT"),PRCA("MESS2"),PRCAT,PRCANM,PRCADEL,PRCATY
- QUIT
- END DO KILLV
- KILL PRCABN,PRCAREF,PRCA
- QUIT
- +1 ;======================= SUBROUTINES ================================
- DIE KILL PRCAT
- WRITE !
- SET DA=PRCABN
- SET DIC="^PRCA(430,"
- SET PRCA("LOCK")=0
- DO LOCKF^PRCAWO1
- if PRCA("LOCK")=1
- QUIT
- SET DIE=DIC
- SET DR="[PRCA CAT SET]"
- DO ^DIE
- IF +$PIECE(^PRCA(430,PRCABN,0),U,2)'>0
- SET PRCADINO=""
- QUIT
- +1 IF '$$ACCK^PRCAACC(PRCABN)
- WRITE !!,*7,"This catergory of bill CAN NOT be re-established.",!
- SET PRCADINO=""
- QUIT
- +2 SET PRCAT=$PIECE(^PRCA(430.2,+$PIECE(^PRCA(430,PRCABN,0),U,2),0),U,6)
- SET PRCAGLN=$PIECE(^(0),U,4)
- if $PIECE(^(0),U,7)=24
- SET PRCAT("C")=1
- D1 SET PRCAREF=1
- SET DR="[PRCA OLD SET]"
- DO ^DIE
- KILL DR
- +1 IF $PIECE(^PRCA(430,PRCABN,0),U,9)'>0
- WRITE !,"Debtor input is not entered.",!
- SET PRCADINO=""
- QUIT
- +2 IF +$PIECE(^PRCA(430,PRCABN,0),U,5)'>0
- WRITE !,"'Bill Resulting From' input is not set.",!
- SET PRCADINO=""
- QUIT
- +3 QUIT
- DISPL ;display the accounts receivable data user has entered.
- +1 if '$DATA(PRCABN)
- QUIT
- IF '$DATA(IOF)
- SET IOP=""
- DO ^%ZIS
- +2 SET D0=PRCABN
- KILL ^UTILITY($JOB,"W")
- SET PRCAIO=IO
- SET PRCAIO(0)=IO(0)
- DO PROC^PRCAPRO
- QUIT
- ASK2 SET %=2
- WRITE !!,"DO YOU WANT TO EDIT THE DATA"
- DO YN^DICN
- if (%<0)!(%=2)
- QUIT
- +1 IF %=0
- WRITE " ANSWER 'Y'(YES) OR 'N'(NO)"
- GOTO ASK2
- +2 SET PRCAOK=1
- QUIT
- ASK1 SET %=2
- WRITE !!,"IS THIS DATA CORRECT"
- DO YN^DICN
- IF %<0
- SET PRCA("EXIT")=""
- QUIT
- +1 IF %=0
- WRITE " ANSWER 'Y'(YES) OR 'N'(NO)"
- GOTO ASK1
- +2 if %'=1
- QUIT
- IF $PIECE(^PRCA(430,PRCABN,0),U,8)=$ORDER(^PRCA(430.3,"AC",106,""))
- WRITE !,"This account has an 'OLD BILL' status and should be edited.",!
- SET PRCAOLD=""
- SET DIE="^PRCA(430,"
- SET DA=PRCABN
- SET DR="8"
- DO ^DIE
- KILL DIE,DR,PRCAOLD
- +3 IF $PIECE(^PRCA(430,PRCABN,0),U,8)=$ORDER(^PRCA(430.3,"AC",106,""))
- WRITE !,"This account still has an 'OLD BILL' status."
- QUIT
- +4 SET $PIECE(^PRCA(430,PRCABN,9),U,6)=$ORDER(^PRCA(430.3,"AC",106,""))
- +5 SET PRCAOK=1
- SET DA=PRCABN
- DO SIG^PRCASIG
- DO NOW^%DTC
- +6 IF $DATA(PRCANM)
- SET $PIECE(^PRCA(430,PRCABN,9),U,1,3)=+DUZ_U_PRCANM_U_%
- +7 QUIT
- DELETE ;delete new AR which has no category and debtor field.
- +1 SET PRCACOMM="USER CANCELED"
- DO DELETE^PRCABIL4
- KILL PRCACOMM
- +2 WRITE *7,!,"The accounts receivable has been deleted!",!
- QUIT
- SEGMT ;save segment number in the file 430 for AMIS report.
- +1 if '$DATA(PRCAT)!$PIECE(^PRCA(430,PRCABN,0),"^",21)
- QUIT
- NEW PRCARI,Y
- +2 SET PRCARI=$ORDER(^PRCA(430.2,"AC",21,0))
- +3 IF PRCAT=PRCARI
- SET X=PRCABN
- if $DATA(^DGCR(399,PRCABN))
- DO ^IBCAMS
- if '$DATA(^DGCR(399,PRCABN))
- SET Y=297
- +4 if '$DATA(Y)
- SET Y=-1
- SET %=$SELECT(PRCARI=PRCAT&(Y<1):"0",PRCARI=PRCAT:Y,$DATA(^PRCA(430.2,PRCAT,0)):$PIECE(^(0),U,3),1:"0")
- +5 IF %=240
- SET %=$SELECT($PIECE(^PRCA(430,PRCABN,0),U,16)>0:$PIECE(^PRCA(430.2,$PIECE(^PRCA(430,PRCABN,0),U,16),0),U,3),1:%)
- +6 SET $PIECE(^PRCA(430,PRCABN,0),U,21)=%
- KILL %,PRCARI,Y
- QUIT