- RCBEUBI1 ;WISC/RFJ-utilties for bills (in file 430) ;1 Jun 00
- ;;4.5;Accounts Receivable;**169**;Mar 20, 1995
- ;;Per VHA Directive 10-93-142, this routine should not be modified.
- Q
- ;
- ;
- DICW ; write identifier code for bill lookup
- N DATA,DATA6,RCX
- S DATA=$G(^PRCA(430,Y,0)) I DATA="" Q
- S DATA6=$G(^PRCA(430,Y,6))
- ; category
- W ?12," ",$E($P($G(^PRCA(430.2,+$P(DATA,"^",2),0)),"^")_" ",1,15)
- ; date active
- I '$P(DATA6,"^",21) S $P(DATA6,"^",21)="???????"
- W ?35," ",$E($P(DATA6,"^",21),4,5),"/",$E($P(DATA6,"^",21),6,7),"/",$E($P(DATA6,"^",21),2,3)
- ; debtor
- S RCX=$X
- S %=$P(DATA,"^",9)
- I %,$D(^RCD(340,%,0)) S %=U_$P($P(^RCD(340,%,0),"^"),";",2)_+^(0)_",0)",%=$S($D(@%):$P(@%,"^"),1:"")
- W ?46," ",$E($S(%="":"NO DEBTOR NAME",1:%),1,$S(RCX<46:20,1:10)_" ")
- ; status
- W ?68," ",$E($P($G(^PRCA(430.3,+$P(DATA,"^",8),0)),"^"),1,9)
- Q
- ;
- ;
- LOOKUP ; special lookup on bills, called from ^dd(430,.01,7.5)
- ; if rcbeflup flag not set, do not use special lookup
- I '$D(RCBEFLUP) Q
- ; user entered A.? for lookup on active bills
- I X["A."!(X["a.") S DIC("S")="I $P(^(0),U,8)=16" S X="?" Q
- ; user entered S.? for lookup on suspended bills
- I X["S."!(X["s.") S DIC("S")="I $P(^(0),U,8)=40" S X="?" Q
- ; user entered O.? for lookup on open bills
- I X["O."!(X["o.") S DIC("S")="I $P(^(0),U,8)=42" S X="?" Q
- ; user entered N.? for lookup on new bills
- I X["N."!(X["n.") S DIC("S")="I $P(^(0),U,8)=18" S X="?" Q
- ; user entered R.? for lookup on refund review bills
- I X["R."!(X["r.") S DIC("S")="I $P(^(0),U,8)=44" S X="?" Q
- K DIC("S")
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCBEUBI1 1646 printed Feb 18, 2025@23:09:16 Page 2
- RCBEUBI1 ;WISC/RFJ-utilties for bills (in file 430) ;1 Jun 00
- +1 ;;4.5;Accounts Receivable;**169**;Mar 20, 1995
- +2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 QUIT
- +4 ;
- +5 ;
- DICW ; write identifier code for bill lookup
- +1 NEW DATA,DATA6,RCX
- +2 SET DATA=$GET(^PRCA(430,Y,0))
- IF DATA=""
- QUIT
- +3 SET DATA6=$GET(^PRCA(430,Y,6))
- +4 ; category
- +5 WRITE ?12," ",$EXTRACT($PIECE($GET(^PRCA(430.2,+$PIECE(DATA,"^",2),0)),"^")_" ",1,15)
- +6 ; date active
- +7 IF '$PIECE(DATA6,"^",21)
- SET $PIECE(DATA6,"^",21)="???????"
- +8 WRITE ?35," ",$EXTRACT($PIECE(DATA6,"^",21),4,5),"/",$EXTRACT($PIECE(DATA6,"^",21),6,7),"/",$EXTRACT($PIECE(DATA6,"^",21),2,3)
- +9 ; debtor
- +10 SET RCX=$X
- +11 SET %=$PIECE(DATA,"^",9)
- +12 IF %
- IF $DATA(^RCD(340,%,0))
- SET %=U_$PIECE($PIECE(^RCD(340,%,0),"^"),";",2)_+^(0)_",0)"
- SET %=$SELECT($DATA(@%):$PIECE(@%,"^"),1:"")
- +13 WRITE ?46," ",$EXTRACT($SELECT(%="":"NO DEBTOR NAME",1:%),1,$SELECT(RCX<46:20,1:10)_" ")
- +14 ; status
- +15 WRITE ?68," ",$EXTRACT($PIECE($GET(^PRCA(430.3,+$PIECE(DATA,"^",8),0)),"^"),1,9)
- +16 QUIT
- +17 ;
- +18 ;
- LOOKUP ; special lookup on bills, called from ^dd(430,.01,7.5)
- +1 ; if rcbeflup flag not set, do not use special lookup
- +2 IF '$DATA(RCBEFLUP)
- QUIT
- +3 ; user entered A.? for lookup on active bills
- +4 IF X["A."!(X["a.")
- SET DIC("S")="I $P(^(0),U,8)=16"
- SET X="?"
- QUIT
- +5 ; user entered S.? for lookup on suspended bills
- +6 IF X["S."!(X["s.")
- SET DIC("S")="I $P(^(0),U,8)=40"
- SET X="?"
- QUIT
- +7 ; user entered O.? for lookup on open bills
- +8 IF X["O."!(X["o.")
- SET DIC("S")="I $P(^(0),U,8)=42"
- SET X="?"
- QUIT
- +9 ; user entered N.? for lookup on new bills
- +10 IF X["N."!(X["n.")
- SET DIC("S")="I $P(^(0),U,8)=18"
- SET X="?"
- QUIT
- +11 ; user entered R.? for lookup on refund review bills
- +12 IF X["R."!(X["r.")
- SET DIC("S")="I $P(^(0),U,8)=44"
- SET X="?"
- QUIT
- +13 KILL DIC("S")
- +14 QUIT
