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 Dec 13, 2024@01:42:52 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
