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

SCRPBK1.m

Go to the documentation of this file. 
  1. SCRPBK1 ;MJK/ALB - RPC Broker Utilities ; 27 FEB 96
  1.  ;;5.3;Scheduling;**41,177**;AUG 13, 1993
  1.  ;
  1. GETDATA(SCDATA,SCTYPE,SCRPTID,SCRPTN,SCTEXT,SCSELS) ;
  1.  ; -- get file type entries for Selections form
  1.  ;
  1.  ; output:  SCDATA(1..n) := info about entity.  NOTE this is now in a
  1.  ;         global location rather than an array for this RPC.
  1.  ;
  1.  ; -- SEE BOTTOM OF SCRPBK FOR MORE VARIABLE DEFINITIONS
  1.  ;
  1.  ; Related RPC: SCRP SELECTION SOURCE
  1.  ;
  1.  S SCDATA=$NA(^TMP($J,"PCMM","SCDATA"))
  1.  ;
  1.  IF SCTYPE="DIVISION" D DIV G GETDATAQ
  1.  ;
  1.  IF SCTYPE="TEAM" D TEAM G GETDATAQ
  1.  ;
  1.  IF SCTYPE="PRACTITIONER" D PRAC G GETDATAQ
  1.  ;
  1.  IF SCTYPE="ROLE" D ROLE G GETDATAQ
  1.  ;
  1.  IF SCTYPE="CLINIC" D CLIN G GETDATAQ
  1.  ;
  1.  IF SCTYPE="USERCLASS" D USER G GETDATAQ
  1.  ;
  1. GETDATAQ Q
  1.  ;
  1. CHK(SCX,SCLEN) ; -- check if text matches user input
  1.  Q SCX=""!($E(SCX,1,SCLEN)'=SCTEXT)
  1.  ;
  1. BACK(X) ; -- backup one char for scanning
  1.  Q $S(X="":"",$L(X)=1:$C($A(X)-1)_$C(122),1:$E(X,1,$L(X)-1)_$C($A($E(X,$L(X)))-1)_$C(122))
  1.  ;
  1. DIV ; -- get institution file entries
  1.  N SCI,Y,SCX,SCLEN,SCINC
  1.  S SCI=0,SCINC=0,SCX=$$BACK(SCTEXT),SCLEN=$L(SCTEXT)
  1.  F  S SCI=$O(^SCTM(404.51,"AINST",SCI)) Q:'SCI  D
  1.  . S Y=SCI,SC0=$G(^DIC(4,Y,0))
  1.  . Q:$$CHK($P(SC0,U),SCLEN)
  1.  . D SET($P(SC0,U)_U_SCTYPE_U_SCI,.SCINC,SCDATA)
  1.  Q
  1.  ;
  1. TEAM ; -- get team file entries
  1.  N SCI,Y,SCX,SCLEN,SCINC,VAUTD
  1.  S SCI=0,SCINC=0,SCX=$$BACK(SCTEXT),SCLEN=$L(SCTEXT)
  1.  D VAUTD(.SCSELS,.VAUTD)
  1.  F  S SCX=$O(^SCTM(404.51,"B",SCX)) Q:$$CHK(SCX,SCLEN)  D
  1.  . F  S SCI=$O(^SCTM(404.51,"B",SCX,SCI)) Q:'SCI  D
  1.  . . S Y=SCI,SC0=$G(^SCTM(404.51,Y,0))
  1.  . . IF $D(VAUTD(+$P(^(0),U,7))) D SET($P(SC0,U)_U_SCTYPE_U_SCI,.SCINC,SCDATA)
  1.  Q
  1.  ;
  1. PRAC ; -- get practitioner entries
  1.  N SCI,Y,SCX,SCLEN,SCINC,VAUTT
  1.  S SCI=0,SCINC=0,SCX=$$BACK(SCTEXT),SCLEN=$L(SCTEXT)
  1.  D VAUTT(.SCSELS,.VAUTT)
  1.  F  S SCX=$O(^VA(200,"B",SCX)) Q:$$CHK(SCX,SCLEN)  D
  1.  . F  S SCI=$O(^VA(200,"B",SCX,SCI)) Q:'SCI  D
  1.  . . S Y=SCI,SC0=$G(^VA(200,Y,0))
  1.  . . IF $D(VAUTT),$$PRACS^SCRPU1() D SET($P(SC0,U)_U_SCTYPE_U_SCI,.SCINC,SCDATA)
  1.  Q
  1.  ;
  1. ROLE ; -- get standard role file entries
  1.  N SCI,Y,SCX,SCLEN,SCINC,VAUTT
  1.  S SCI=0,SCINC=0,SCX=$$BACK(SCTEXT),SCLEN=$L(SCTEXT)
  1.  D VAUTT(.SCSELS,.VAUTT)
  1.  F  S SCX=$O(^SD(403.46,"B",SCX)) Q:$$CHK(SCX,SCLEN)  D
  1.  . F  S SCI=$O(^SD(403.46,"B",SCX,SCI)) Q:'SCI  D
  1.  . . S Y=SCI,SC0=$G(^SD(403.46,SCI,0))
  1.  . . IF $D(VAUTT),$$RL^SCRPU1() D SET($P(SC0,U)_U_SCTYPE_U_SCI,.SCINC,SCDATA)
  1.  Q
  1.  ;
  1. CLIN ; -- get clinic entries
  1.  N SCI,Y,SCX,SCLEN,SCINC,VAUTD,VAUTT,SCLIN
  1.  S SCLIN="^TMP($J,""PCMM"",""SCLIN"")"
  1.  K @SCLIN
  1.  S SCI=0,SCINC=0,SCLEN=$L(SCTEXT)
  1.  IF SCRPTID=2 D
  1.  . Q
  1.  ELSE  D
  1.  . D VAUTT(.SCSELS,.VAUTT)
  1.  F SCXREF="B","C","TEAMS" S SCX=$$BACK(SCTEXT) D  Q:SCTEXT=""
  1.  . F  S SCX=$O(^SC(SCXREF,SCX)) Q:$$CHK(SCX,SCLEN)  D
  1.  . . F  S SCI=$O(^SC(SCXREF,SCX,SCI)) Q:'SCI  IF '$D(@SCLIN@(SCI)) D
  1.  . . . S Y=SCI,SC0=$G(^SC(Y,0))
  1.  . . . IF SCRPTID=2,$$CLSC2^SCRPU1() D SET($P(SC0,U)_U_SCTYPE_U_SCI,.SCINC,SCDATA) S @SCLIN@(SCI)=""
  1.  . . . IF SCRPTID'=2,$D(VAUTT),$$CLSC^SCRPU1() D SET($P(SC0,U)_U_SCTYPE_U_SCI,.SCINC,SCDATA)
  1.  K @SCLIN
  1.  Q
  1.  ;
  1. USER ; -- get user class file entries
  1.  N SCI,Y,SCX,SCLEN,SCINC,VAUTT
  1.  S SCI=0,SCINC=0,SCX=$$BACK(SCTEXT),SCLEN=$L(SCTEXT)
  1.  D VAUTT(.SCSELS,.VAUTT)
  1.  F  S SCX=$O(^USR(8930,"B",SCX)) Q:$$CHK(SCX,SCLEN)  D
  1.  . F  S SCI=$O(^USR(8930,"B",SCX,SCI)) Q:'SCI  D
  1.  . . S Y=SCI,SC0=$G(^USR(8930,SCI,0))
  1.  . . IF $D(VAUTT),$$USRCL^SCRPU1() D SET($P(SC0,U)_U_SCTYPE_U_SCI,.SCINC,SCDATA)
  1.  Q
  1.  ;
  1. VAUTD(SCSELS,VAUTD) ; -- build division util array
  1.  N I,X
  1.  F I=1:1 S X=$G(SCSELS(I)) Q:X=""  IF $P(X,U,2)="DIVISION" S VAUTD(+$P(X,U,3))=$P(X,U)
  1.  S:$D(VAUTD) VAUTD=0
  1.  Q
  1.  ;
  1. VAUTT(SCSELS,VAUTT) ; -- build team util array
  1.  N I,X
  1.  IF SCRPTID=3 S VAUTT=1 G VAUTTQ
  1.  F I=1:1 S X=$G(SCSELS(I)) Q:X=""  IF $P(X,U,2)="TEAM" S VAUTT(+$P(X,U,3))=$P(X,U)
  1.  S:$D(VAUTT) VAUTT=0
  1. VAUTTQ Q
  1.  ;
  1. SET(X,INC,SCDATA) ; -- set value in return array
  1.  S INC=$G(INC)+1,@SCDATA@(INC)=X
  1.  Q
  1.  ;