Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: RCRCDIV

RCRCDIV.m

Go to the documentation of this file. 
  1. RCRCDIV ;ALB/CMS-RC REFERRAL DIVISION UTILITY PROGRAM ; 16-JUN-00
  1. V ;;4.5;Accounts Receivable;**159**;Mar 20, 1995
  1.  ;;Per VHA Directive 10-93-142, this routine should not be modified.
  1.  Q
  1.  ;
  1. RCDIV(ARRAY) ;Get array of divisions and Remote Address
  1.  ;Returns ARRAY(0)=Number of divisions^Primary 40.8 ien
  1.  ;        ARRAY(40.8#IEN)="P" for Primary (default) or null^Domain Name
  1.  ;                       =^Inst. file#^Inst. name^Station #
  1.  ;        or:  ARRAY(0) Not Definded
  1.  ;
  1.  N CNT,RCA,RCS,RCX,RCY
  1.  S CNT=0,RCX=$O(^RCT(349.1,"B","RC",0))
  1.  I ('RCX)!('$O(^RCT(349.1,+RCX,6,0))) G RCDIVQ
  1.  ;S RCS=$$SITE^VASITE,RCY=$P(RCS,U,2),RCY=$O(^DG(40.8,"B",RCY,0))
  1.  ;S RCS=$$SITE^VASITE S RCY=$P(RCS,U,2) S RCY=$O(^DG(40.8,"B",RCY,0))
  1.  S RCS=$$SITE^VASITE S RCY=$P(RCS,U,1) S RCY=$O(^DG(40.8,"AD",RCY,0))
  1.  I 'RCY G RCDIVQ
  1.  ;S ARRAY(RCY)="P^"_$P($G(^RCT(349.1,+RCX,3)),U,3)_"^"_RCS
  1.  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)
  1.  S $P(ARRAY(0),U,2)=RCY,CNT=CNT+1
  1.  S RCY=0 F  S RCY=$O(^RCT(349.1,+RCX,6,RCY)) Q:'RCY  D
  1.  .S RCA=$G(^RCT(349.1,+RCX,6,RCY,0))
  1.  .I $D(ARRAY(+RCA)) Q
  1.  .;S ARRAY(+RCA)="^"_$P($G(^DIC(4.2,+$P(RCA,U,2),0)),U,1)_"^"_$$SITE^VASITE(,+RCA)
  1.  .S ARRAY(+RCA)="^"_$P($G(^DIC(4.2,+$P(RCA,U,2),0)),U,1)_"^"_$$SITE^VASITE(,+RCA)_"^"_$P(RCA,"^",3)_"^"_$P(RCA,"^",4)
  1.  .I $P(ARRAY(+RCA),"^",3)=-1 K ARRAY(+RCA)
  1.  .S CNT=CNT+1
  1.  S $P(ARRAY(0),U,1)=CNT
  1.  ; If only site in multiple is same as primary kill RCDIV
  1.  I CNT=1 K RCDIV
  1. RCDIVQ Q
  1.  ; 
  1. DIVS ;Select division if multi-site
  1.  ; - Use RCDIV^RCRCDIV(.RCDIV) to set RCDIV(0)
  1.  ;
  1.  K ^TMP("RCDOMAIN",$J)
  1.  N CNT,DIR,RCDOMAIN,RCI,RCS,RCX,TCNT,X,Y
  1.  I '$O(RCDIV(0)) G DIVSQ
  1.  S (CNT,RCX)=0,RCS="" K DIR
  1.  F  S RCX=$O(RCDIV(RCX)) Q:'RCX  D
  1.  .S CNT=CNT+1
  1.  .S DIR("A",CNT)=CNT_".   "_$P(RCDIV(RCX),U,5)_"  "_$P(RCDIV(RCX),U,4)
  1.  .;S RCS=RCS_CNT_":"_RCX_"  "_$P(RCDIV(RCX),U,4)_"  "_$P(RCDIV(RCX),U,2)_";"
  1.  .;S RCS(CNT)=CNT_":"_RCX_"  "_$P(RCDIV(RCX),U,4)_"  "_$P(RCDIV(RCX),U,2)
  1.  .S RCDIV(RCX)=RCDIV(RCX)_"^"_CNT
  1.  .I $P(RCDIV(RCX),U,1)="P" S DIR("B")=CNT
  1.  S TCNT=CNT,CNT=CNT+1,DIR("A",CNT)=" "
  1.  S CNT=CNT+1,DIR("A",CNT)=" "
  1.  S DIR("A")=" Enter a number: "
  1.  W !!,"Medical Center Division to include in Build List"
  1.  W !," Select one of the following:         (Required)",!
  1.  S DIR(0)="NO^1:"_TCNT
  1.  ;S DIR(0)="SAXB^"_RCS
  1.  D ^DIR W !
  1.  I $E(Y)="^" S RCOUT=1 G DIVSQ
  1.  S RCI=0 F  S RCI=$O(RCDIV(RCI)) Q:'RCI  I $P(RCDIV(+RCI),"^",8)'=Y K RCDIV(RCI)
  1.  S $P(RCDIV(0),U,3)=$O(RCDIV(0))
  1.  S $P(^TMP("RCDOMAIN",$J,0),U,3)=$O(RCDIV(0))
  1.  S ^TMP("RCDOMAIN",$J,$P(RCDIV(0),U,3))=RCDIV($P(RCDIV(0),U,3))
  1.  I $D(DIRUT)!$D(DTOUT)!$D(DUOUT)!$D(DIROUT) G DIVSQ
  1.  K DIR,DIROUT,DTOUT,DUOUT,DIRUT
  1. DIVSQ Q
  1.  ;
  1. DIV(PRCABN) ;Check bill # to see if same as selected division
  1.  ;  Returns 1 if same as selected divison 0 if not
  1.  ;  RCDIV(0) must be defined before calling
  1.  N RCX S RCX=0
  1.  I '$G(RCDIV(0)) G DIVQ
  1.  I $P($G(RCDIV(0)),U,3)=$$DIV^IBJDF2(PRCABN) S RCX=1
  1. DIVQ Q RCX
  1.  ;
  1.  ;RCRCDIV