| [613] | 1 | RCRCDIV ;ALB/CMS-RC REFERRAL DIVISION UTILITY PROGRAM ; 16-JUN-00
|
|---|
| 2 | V ;;4.5;Accounts Receivable;**159**;Mar 20, 1995
|
|---|
| 3 | ;;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | Q
|
|---|
| 5 | ;
|
|---|
| 6 | RCDIV(ARRAY) ;Get array of divisions and Remote Address
|
|---|
| 7 | ;Returns ARRAY(0)=Number of divisions^Primary 40.8 ien
|
|---|
| 8 | ; ARRAY(40.8#IEN)="P" for Primary (default) or null^Domain Name
|
|---|
| 9 | ; =^Inst. file#^Inst. name^Station #
|
|---|
| 10 | ; or: ARRAY(0) Not Definded
|
|---|
| 11 | ;
|
|---|
| 12 | N CNT,RCA,RCS,RCX,RCY
|
|---|
| 13 | S CNT=0,RCX=$O(^RCT(349.1,"B","RC",0))
|
|---|
| 14 | I ('RCX)!('$O(^RCT(349.1,+RCX,6,0))) G RCDIVQ
|
|---|
| 15 | ;S RCS=$$SITE^VASITE,RCY=$P(RCS,U,2),RCY=$O(^DG(40.8,"B",RCY,0))
|
|---|
| 16 | ;S RCS=$$SITE^VASITE S RCY=$P(RCS,U,2) S RCY=$O(^DG(40.8,"B",RCY,0))
|
|---|
| 17 | S RCS=$$SITE^VASITE S RCY=$P(RCS,U,1) S RCY=$O(^DG(40.8,"AD",RCY,0))
|
|---|
| 18 | I 'RCY G RCDIVQ
|
|---|
| 19 | ;S ARRAY(RCY)="P^"_$P($G(^RCT(349.1,+RCX,3)),U,3)_"^"_RCS
|
|---|
| 20 | 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)
|
|---|
| 21 | S $P(ARRAY(0),U,2)=RCY,CNT=CNT+1
|
|---|
| 22 | S RCY=0 F S RCY=$O(^RCT(349.1,+RCX,6,RCY)) Q:'RCY D
|
|---|
| 23 | .S RCA=$G(^RCT(349.1,+RCX,6,RCY,0))
|
|---|
| 24 | .I $D(ARRAY(+RCA)) Q
|
|---|
| 25 | .;S ARRAY(+RCA)="^"_$P($G(^DIC(4.2,+$P(RCA,U,2),0)),U,1)_"^"_$$SITE^VASITE(,+RCA)
|
|---|
| 26 | .S ARRAY(+RCA)="^"_$P($G(^DIC(4.2,+$P(RCA,U,2),0)),U,1)_"^"_$$SITE^VASITE(,+RCA)_"^"_$P(RCA,"^",3)_"^"_$P(RCA,"^",4)
|
|---|
| 27 | .I $P(ARRAY(+RCA),"^",3)=-1 K ARRAY(+RCA)
|
|---|
| 28 | .S CNT=CNT+1
|
|---|
| 29 | S $P(ARRAY(0),U,1)=CNT
|
|---|
| 30 | ; If only site in multiple is same as primary kill RCDIV
|
|---|
| 31 | I CNT=1 K RCDIV
|
|---|
| 32 | RCDIVQ Q
|
|---|
| 33 | ;
|
|---|
| 34 | DIVS ;Select division if multi-site
|
|---|
| 35 | ; - Use RCDIV^RCRCDIV(.RCDIV) to set RCDIV(0)
|
|---|
| 36 | ;
|
|---|
| 37 | K ^TMP("RCDOMAIN",$J)
|
|---|
| 38 | N CNT,DIR,RCDOMAIN,RCI,RCS,RCX,TCNT,X,Y
|
|---|
| 39 | I '$O(RCDIV(0)) G DIVSQ
|
|---|
| 40 | S (CNT,RCX)=0,RCS="" K DIR
|
|---|
| 41 | F S RCX=$O(RCDIV(RCX)) Q:'RCX D
|
|---|
| 42 | .S CNT=CNT+1
|
|---|
| 43 | .S DIR("A",CNT)=CNT_". "_$P(RCDIV(RCX),U,5)_" "_$P(RCDIV(RCX),U,4)
|
|---|
| 44 | .;S RCS=RCS_CNT_":"_RCX_" "_$P(RCDIV(RCX),U,4)_" "_$P(RCDIV(RCX),U,2)_";"
|
|---|
| 45 | .;S RCS(CNT)=CNT_":"_RCX_" "_$P(RCDIV(RCX),U,4)_" "_$P(RCDIV(RCX),U,2)
|
|---|
| 46 | .S RCDIV(RCX)=RCDIV(RCX)_"^"_CNT
|
|---|
| 47 | .I $P(RCDIV(RCX),U,1)="P" S DIR("B")=CNT
|
|---|
| 48 | S TCNT=CNT,CNT=CNT+1,DIR("A",CNT)=" "
|
|---|
| 49 | S CNT=CNT+1,DIR("A",CNT)=" "
|
|---|
| 50 | S DIR("A")=" Enter a number: "
|
|---|
| 51 | W !!,"Medical Center Division to include in Build List"
|
|---|
| 52 | W !," Select one of the following: (Required)",!
|
|---|
| 53 | S DIR(0)="NO^1:"_TCNT
|
|---|
| 54 | ;S DIR(0)="SAXB^"_RCS
|
|---|
| 55 | D ^DIR W !
|
|---|
| 56 | I $E(Y)="^" S RCOUT=1 G DIVSQ
|
|---|
| 57 | S RCI=0 F S RCI=$O(RCDIV(RCI)) Q:'RCI I $P(RCDIV(+RCI),"^",8)'=Y K RCDIV(RCI)
|
|---|
| 58 | S $P(RCDIV(0),U,3)=$O(RCDIV(0))
|
|---|
| 59 | S $P(^TMP("RCDOMAIN",$J,0),U,3)=$O(RCDIV(0))
|
|---|
| 60 | S ^TMP("RCDOMAIN",$J,$P(RCDIV(0),U,3))=RCDIV($P(RCDIV(0),U,3))
|
|---|
| 61 | I $D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) G DIVSQ
|
|---|
| 62 | K DIR,DIROUT,DTOUT,DUOUT,DIRUT
|
|---|
| 63 | DIVSQ Q
|
|---|
| 64 | ;
|
|---|
| 65 | DIV(PRCABN) ;Check bill # to see if same as selected division
|
|---|
| 66 | ; Returns 1 if same as selected divison 0 if not
|
|---|
| 67 | ; RCDIV(0) must be defined before calling
|
|---|
| 68 | N RCX S RCX=0
|
|---|
| 69 | I '$G(RCDIV(0)) G DIVQ
|
|---|
| 70 | I $P($G(RCDIV(0)),U,3)=$$DIV^IBJDF2(PRCABN) S RCX=1
|
|---|
| 71 | DIVQ Q RCX
|
|---|
| 72 | ;
|
|---|
| 73 | ;RCRCDIV
|
|---|
