RCRCDIV ;ALB/CMS-RC REFERRAL DIVISION UTILITY PROGRAM ; 16-JUN-00
V ;;4.5;Accounts Receivable;**159**;Mar 20, 1995
;;Per VHA Directive 10-93-142, this routine should not be modified.
Q
;
RCDIV(ARRAY) ;Get array of divisions and Remote Address
;Returns ARRAY(0)=Number of divisions^Primary 40.8 ien
; ARRAY(40.8#IEN)="P" for Primary (default) or null^Domain Name
; =^Inst. file#^Inst. name^Station #
; or: ARRAY(0) Not Definded
;
N CNT,RCA,RCS,RCX,RCY
S CNT=0,RCX=$O(^RCT(349.1,"B","RC",0))
I ('RCX)!('$O(^RCT(349.1,+RCX,6,0))) G RCDIVQ
;S RCS=$$SITE^VASITE,RCY=$P(RCS,U,2),RCY=$O(^DG(40.8,"B",RCY,0))
;S RCS=$$SITE^VASITE S RCY=$P(RCS,U,2) S RCY=$O(^DG(40.8,"B",RCY,0))
S RCS=$$SITE^VASITE S RCY=$P(RCS,U,1) S RCY=$O(^DG(40.8,"AD",RCY,0))
I 'RCY G RCDIVQ
;S ARRAY(RCY)="P^"_$P($G(^RCT(349.1,+RCX,3)),U,3)_"^"_RCS
S ARRAY(RCY)="P^"_$P($G(^RCT(349.1,+RCX,3)),U,3)_"^"_RCS_"^"_$P($G(^RCT(349.1,+RCX,3)),U,4)_"^"_$P($G(^RCT(349.1,+RCX,3)),U,5)
S $P(ARRAY(0),U,2)=RCY,CNT=CNT+1
S RCY=0 F S RCY=$O(^RCT(349.1,+RCX,6,RCY)) Q:'RCY D
.S RCA=$G(^RCT(349.1,+RCX,6,RCY,0))
.I $D(ARRAY(+RCA)) Q
.;S ARRAY(+RCA)="^"_$P($G(^DIC(4.2,+$P(RCA,U,2),0)),U,1)_"^"_$$SITE^VASITE(,+RCA)
.S ARRAY(+RCA)="^"_$P($G(^DIC(4.2,+$P(RCA,U,2),0)),U,1)_"^"_$$SITE^VASITE(,+RCA)_"^"_$P(RCA,"^",3)_"^"_$P(RCA,"^",4)
.I $P(ARRAY(+RCA),"^",3)=-1 K ARRAY(+RCA)
.S CNT=CNT+1
S $P(ARRAY(0),U,1)=CNT
; If only site in multiple is same as primary kill RCDIV
I CNT=1 K RCDIV
RCDIVQ Q
;
DIVS ;Select division if multi-site
; - Use RCDIV^RCRCDIV(.RCDIV) to set RCDIV(0)
;
K ^TMP("RCDOMAIN",$J)
N CNT,DIR,RCDOMAIN,RCI,RCS,RCX,TCNT,X,Y
I '$O(RCDIV(0)) G DIVSQ
S (CNT,RCX)=0,RCS="" K DIR
F S RCX=$O(RCDIV(RCX)) Q:'RCX D
.S CNT=CNT+1
.S DIR("A",CNT)=CNT_". "_$P(RCDIV(RCX),U,5)_" "_$P(RCDIV(RCX),U,4)
.;S RCS=RCS_CNT_":"_RCX_" "_$P(RCDIV(RCX),U,4)_" "_$P(RCDIV(RCX),U,2)_";"
.;S RCS(CNT)=CNT_":"_RCX_" "_$P(RCDIV(RCX),U,4)_" "_$P(RCDIV(RCX),U,2)
.S RCDIV(RCX)=RCDIV(RCX)_"^"_CNT
.I $P(RCDIV(RCX),U,1)="P" S DIR("B")=CNT
S TCNT=CNT,CNT=CNT+1,DIR("A",CNT)=" "
S CNT=CNT+1,DIR("A",CNT)=" "
S DIR("A")=" Enter a number: "
W !!,"Medical Center Division to include in Build List"
W !," Select one of the following: (Required)",!
S DIR(0)="NO^1:"_TCNT
;S DIR(0)="SAXB^"_RCS
D ^DIR W !
I $E(Y)="^" S RCOUT=1 G DIVSQ
S RCI=0 F S RCI=$O(RCDIV(RCI)) Q:'RCI I $P(RCDIV(+RCI),"^",8)'=Y K RCDIV(RCI)
S $P(RCDIV(0),U,3)=$O(RCDIV(0))
S $P(^TMP("RCDOMAIN",$J,0),U,3)=$O(RCDIV(0))
S ^TMP("RCDOMAIN",$J,$P(RCDIV(0),U,3))=RCDIV($P(RCDIV(0),U,3))
I $D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) G DIVSQ
K DIR,DIROUT,DTOUT,DUOUT,DIRUT
DIVSQ Q
;
DIV(PRCABN) ;Check bill # to see if same as selected division
; Returns 1 if same as selected divison 0 if not
; RCDIV(0) must be defined before calling
N RCX S RCX=0
I '$G(RCDIV(0)) G DIVQ
I $P($G(RCDIV(0)),U,3)=$$DIV^IBJDF2(PRCABN) S RCX=1
DIVQ Q RCX
;
;RCRCDIV
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HRCRCDIV 3032 printed Dec 13, 2024@01:47:37 Page 2
RCRCDIV ;ALB/CMS-RC REFERRAL DIVISION UTILITY PROGRAM ; 16-JUN-00
V ;;4.5;Accounts Receivable;**159**;Mar 20, 1995
+1 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+2 QUIT
+3 ;
RCDIV(ARRAY) ;Get array of divisions and Remote Address
+1 ;Returns ARRAY(0)=Number of divisions^Primary 40.8 ien
+2 ; ARRAY(40.8#IEN)="P" for Primary (default) or null^Domain Name
+3 ; =^Inst. file#^Inst. name^Station #
+4 ; or: ARRAY(0) Not Definded
+5 ;
+6 NEW CNT,RCA,RCS,RCX,RCY
+7 SET CNT=0
SET RCX=$ORDER(^RCT(349.1,"B","RC",0))
+8 IF ('RCX)!('$ORDER(^RCT(349.1,+RCX,6,0)))
GOTO RCDIVQ
+9 ;S RCS=$$SITE^VASITE,RCY=$P(RCS,U,2),RCY=$O(^DG(40.8,"B",RCY,0))
+10 ;S RCS=$$SITE^VASITE S RCY=$P(RCS,U,2) S RCY=$O(^DG(40.8,"B",RCY,0))
+11 SET RCS=$$SITE^VASITE
SET RCY=$PIECE(RCS,U,1)
SET RCY=$ORDER(^DG(40.8,"AD",RCY,0))
+12 IF 'RCY
GOTO RCDIVQ
+13 ;S ARRAY(RCY)="P^"_$P($G(^RCT(349.1,+RCX,3)),U,3)_"^"_RCS
+14 SET ARRAY(RCY)="P^"_$PIECE($GET(^RCT(349.1,+RCX,3)),U,3)_"^"_RCS_"^"_$PIECE($GET(^RCT(349.1,+RCX,3)),U,4)_"^"_$PIECE($GET(^RCT(349.1,+RCX,3)),U,5)
+15 SET $PIECE(ARRAY(0),U,2)=RCY
SET CNT=CNT+1
+16 SET RCY=0
FOR
SET RCY=$ORDER(^RCT(349.1,+RCX,6,RCY))
if 'RCY
QUIT
Begin DoDot:1
+17 SET RCA=$GET(^RCT(349.1,+RCX,6,RCY,0))
+18 IF $DATA(ARRAY(+RCA))
QUIT
+19 ;S ARRAY(+RCA)="^"_$P($G(^DIC(4.2,+$P(RCA,U,2),0)),U,1)_"^"_$$SITE^VASITE(,+RCA)
+20 SET ARRAY(+RCA)="^"_$PIECE($GET(^DIC(4.2,+$PIECE(RCA,U,2),0)),U,1)_"^"_$$SITE^VASITE(,+RCA)_"^"_$PIECE(RCA,"^",3)_"^"_$PIECE(RCA,"^",4)
+21 IF $PIECE(ARRAY(+RCA),"^",3)=-1
KILL ARRAY(+RCA)
+22 SET CNT=CNT+1
End DoDot:1
+23 SET $PIECE(ARRAY(0),U,1)=CNT
+24 ; If only site in multiple is same as primary kill RCDIV
+25 IF CNT=1
KILL RCDIV
RCDIVQ QUIT
+1 ;
DIVS ;Select division if multi-site
+1 ; - Use RCDIV^RCRCDIV(.RCDIV) to set RCDIV(0)
+2 ;
+3 KILL ^TMP("RCDOMAIN",$JOB)
+4 NEW CNT,DIR,RCDOMAIN,RCI,RCS,RCX,TCNT,X,Y
+5 IF '$ORDER(RCDIV(0))
GOTO DIVSQ
+6 SET (CNT,RCX)=0
SET RCS=""
KILL DIR
+7 FOR
SET RCX=$ORDER(RCDIV(RCX))
if 'RCX
QUIT
Begin DoDot:1
+8 SET CNT=CNT+1
+9 SET DIR("A",CNT)=CNT_". "_$PIECE(RCDIV(RCX),U,5)_" "_$PIECE(RCDIV(RCX),U,4)
+10 ;S RCS=RCS_CNT_":"_RCX_" "_$P(RCDIV(RCX),U,4)_" "_$P(RCDIV(RCX),U,2)_";"
+11 ;S RCS(CNT)=CNT_":"_RCX_" "_$P(RCDIV(RCX),U,4)_" "_$P(RCDIV(RCX),U,2)
+12 SET RCDIV(RCX)=RCDIV(RCX)_"^"_CNT
+13 IF $PIECE(RCDIV(RCX),U,1)="P"
SET DIR("B")=CNT
End DoDot:1
+14 SET TCNT=CNT
SET CNT=CNT+1
SET DIR("A",CNT)=" "
+15 SET CNT=CNT+1
SET DIR("A",CNT)=" "
+16 SET DIR("A")=" Enter a number: "
+17 WRITE !!,"Medical Center Division to include in Build List"
+18 WRITE !," Select one of the following: (Required)",!
+19 SET DIR(0)="NO^1:"_TCNT
+20 ;S DIR(0)="SAXB^"_RCS
+21 DO ^DIR
WRITE !
+22 IF $EXTRACT(Y)="^"
SET RCOUT=1
GOTO DIVSQ
+23 SET RCI=0
FOR
SET RCI=$ORDER(RCDIV(RCI))
if 'RCI
QUIT
IF $PIECE(RCDIV(+RCI),"^",8)'=Y
KILL RCDIV(RCI)
+24 SET $PIECE(RCDIV(0),U,3)=$ORDER(RCDIV(0))
+25 SET $PIECE(^TMP("RCDOMAIN",$JOB,0),U,3)=$ORDER(RCDIV(0))
+26 SET ^TMP("RCDOMAIN",$JOB,$PIECE(RCDIV(0),U,3))=RCDIV($PIECE(RCDIV(0),U,3))
+27 IF $DATA(DIRUT)!$DATA(DTOUT)!$DATA(DUOUT)!$DATA(DIROUT)
GOTO DIVSQ
+28 KILL DIR,DIROUT,DTOUT,DUOUT,DIRUT
DIVSQ QUIT
+1 ;
DIV(PRCABN) ;Check bill # to see if same as selected division
+1 ; Returns 1 if same as selected divison 0 if not
+2 ; RCDIV(0) must be defined before calling
+3 NEW RCX
SET RCX=0
+4 IF '$GET(RCDIV(0))
GOTO DIVQ
+5 IF $PIECE($GET(RCDIV(0)),U,3)=$$DIV^IBJDF2(PRCABN)
SET RCX=1
DIVQ QUIT RCX
+1 ;
+2 ;RCRCDIV
