source: WorldVistAEHR/trunk/r/ACCOUNTS_RECEIVABLE-PRCA-PRY-RC/RCRCDIV.m@ 1141

Last change on this file since 1141 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 2.9 KB
Line 
1RCRCDIV ;ALB/CMS-RC REFERRAL DIVISION UTILITY PROGRAM ; 16-JUN-00
2V ;;4.5;Accounts Receivable;**159**;Mar 20, 1995
3 ;;Per VHA Directive 10-93-142, this routine should not be modified.
4 Q
5 ;
6RCDIV(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
32RCDIVQ Q
33 ;
34DIVS ;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
63DIVSQ Q
64 ;
65DIV(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
71DIVQ Q RCX
72 ;
73 ;RCRCDIV
Note: See TracBrowser for help on using the repository browser.