SCRPBK1 ;MJK/ALB - RPC Broker Utilities ; 27 FEB 96
;;5.3;Scheduling;**41,177**;AUG 13, 1993
;
GETDATA(SCDATA,SCTYPE,SCRPTID,SCRPTN,SCTEXT,SCSELS) ;
; -- get file type entries for Selections form
;
; output: SCDATA(1..n) := info about entity. NOTE this is now in a
; global location rather than an array for this RPC.
;
; -- SEE BOTTOM OF SCRPBK FOR MORE VARIABLE DEFINITIONS
;
; Related RPC: SCRP SELECTION SOURCE
;
S SCDATA=$NA(^TMP($J,"PCMM","SCDATA"))
;
IF SCTYPE="DIVISION" D DIV G GETDATAQ
;
IF SCTYPE="TEAM" D TEAM G GETDATAQ
;
IF SCTYPE="PRACTITIONER" D PRAC G GETDATAQ
;
IF SCTYPE="ROLE" D ROLE G GETDATAQ
;
IF SCTYPE="CLINIC" D CLIN G GETDATAQ
;
IF SCTYPE="USERCLASS" D USER G GETDATAQ
;
GETDATAQ Q
;
CHK(SCX,SCLEN) ; -- check if text matches user input
Q SCX=""!($E(SCX,1,SCLEN)'=SCTEXT)
;
BACK(X) ; -- backup one char for scanning
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))
;
DIV ; -- get institution file entries
N SCI,Y,SCX,SCLEN,SCINC
S SCI=0,SCINC=0,SCX=$$BACK(SCTEXT),SCLEN=$L(SCTEXT)
F S SCI=$O(^SCTM(404.51,"AINST",SCI)) Q:'SCI D
. S Y=SCI,SC0=$G(^DIC(4,Y,0))
. Q:$$CHK($P(SC0,U),SCLEN)
. D SET($P(SC0,U)_U_SCTYPE_U_SCI,.SCINC,SCDATA)
Q
;
TEAM ; -- get team file entries
N SCI,Y,SCX,SCLEN,SCINC,VAUTD
S SCI=0,SCINC=0,SCX=$$BACK(SCTEXT),SCLEN=$L(SCTEXT)
D VAUTD(.SCSELS,.VAUTD)
F S SCX=$O(^SCTM(404.51,"B",SCX)) Q:$$CHK(SCX,SCLEN) D
. F S SCI=$O(^SCTM(404.51,"B",SCX,SCI)) Q:'SCI D
. . S Y=SCI,SC0=$G(^SCTM(404.51,Y,0))
. . IF $D(VAUTD(+$P(^(0),U,7))) D SET($P(SC0,U)_U_SCTYPE_U_SCI,.SCINC,SCDATA)
Q
;
PRAC ; -- get practitioner entries
N SCI,Y,SCX,SCLEN,SCINC,VAUTT
S SCI=0,SCINC=0,SCX=$$BACK(SCTEXT),SCLEN=$L(SCTEXT)
D VAUTT(.SCSELS,.VAUTT)
F S SCX=$O(^VA(200,"B",SCX)) Q:$$CHK(SCX,SCLEN) D
. F S SCI=$O(^VA(200,"B",SCX,SCI)) Q:'SCI D
. . S Y=SCI,SC0=$G(^VA(200,Y,0))
. . IF $D(VAUTT),$$PRACS^SCRPU1() D SET($P(SC0,U)_U_SCTYPE_U_SCI,.SCINC,SCDATA)
Q
;
ROLE ; -- get standard role file entries
N SCI,Y,SCX,SCLEN,SCINC,VAUTT
S SCI=0,SCINC=0,SCX=$$BACK(SCTEXT),SCLEN=$L(SCTEXT)
D VAUTT(.SCSELS,.VAUTT)
F S SCX=$O(^SD(403.46,"B",SCX)) Q:$$CHK(SCX,SCLEN) D
. F S SCI=$O(^SD(403.46,"B",SCX,SCI)) Q:'SCI D
. . S Y=SCI,SC0=$G(^SD(403.46,SCI,0))
. . IF $D(VAUTT),$$RL^SCRPU1() D SET($P(SC0,U)_U_SCTYPE_U_SCI,.SCINC,SCDATA)
Q
;
CLIN ; -- get clinic entries
N SCI,Y,SCX,SCLEN,SCINC,VAUTD,VAUTT,SCLIN
S SCLIN="^TMP($J,""PCMM"",""SCLIN"")"
K @SCLIN
S SCI=0,SCINC=0,SCLEN=$L(SCTEXT)
IF SCRPTID=2 D
. Q
ELSE D
. D VAUTT(.SCSELS,.VAUTT)
F SCXREF="B","C","TEAMS" S SCX=$$BACK(SCTEXT) D Q:SCTEXT=""
. F S SCX=$O(^SC(SCXREF,SCX)) Q:$$CHK(SCX,SCLEN) D
. . F S SCI=$O(^SC(SCXREF,SCX,SCI)) Q:'SCI IF '$D(@SCLIN@(SCI)) D
. . . S Y=SCI,SC0=$G(^SC(Y,0))
. . . IF SCRPTID=2,$$CLSC2^SCRPU1() D SET($P(SC0,U)_U_SCTYPE_U_SCI,.SCINC,SCDATA) S @SCLIN@(SCI)=""
. . . IF SCRPTID'=2,$D(VAUTT),$$CLSC^SCRPU1() D SET($P(SC0,U)_U_SCTYPE_U_SCI,.SCINC,SCDATA)
K @SCLIN
Q
;
USER ; -- get user class file entries
N SCI,Y,SCX,SCLEN,SCINC,VAUTT
S SCI=0,SCINC=0,SCX=$$BACK(SCTEXT),SCLEN=$L(SCTEXT)
D VAUTT(.SCSELS,.VAUTT)
F S SCX=$O(^USR(8930,"B",SCX)) Q:$$CHK(SCX,SCLEN) D
. F S SCI=$O(^USR(8930,"B",SCX,SCI)) Q:'SCI D
. . S Y=SCI,SC0=$G(^USR(8930,SCI,0))
. . IF $D(VAUTT),$$USRCL^SCRPU1() D SET($P(SC0,U)_U_SCTYPE_U_SCI,.SCINC,SCDATA)
Q
;
VAUTD(SCSELS,VAUTD) ; -- build division util array
N I,X
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)
S:$D(VAUTD) VAUTD=0
Q
;
VAUTT(SCSELS,VAUTT) ; -- build team util array
N I,X
IF SCRPTID=3 S VAUTT=1 G VAUTTQ
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)
S:$D(VAUTT) VAUTT=0
VAUTTQ Q
;
SET(X,INC,SCDATA) ; -- set value in return array
S INC=$G(INC)+1,@SCDATA@(INC)=X
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCRPBK1 3971 printed Dec 13, 2024@02:42:21 Page 2
SCRPBK1 ;MJK/ALB - RPC Broker Utilities ; 27 FEB 96
+1 ;;5.3;Scheduling;**41,177**;AUG 13, 1993
+2 ;
GETDATA(SCDATA,SCTYPE,SCRPTID,SCRPTN,SCTEXT,SCSELS) ;
+1 ; -- get file type entries for Selections form
+2 ;
+3 ; output: SCDATA(1..n) := info about entity. NOTE this is now in a
+4 ; global location rather than an array for this RPC.
+5 ;
+6 ; -- SEE BOTTOM OF SCRPBK FOR MORE VARIABLE DEFINITIONS
+7 ;
+8 ; Related RPC: SCRP SELECTION SOURCE
+9 ;
+10 SET SCDATA=$NAME(^TMP($JOB,"PCMM","SCDATA"))
+11 ;
+12 IF SCTYPE="DIVISION"
DO DIV
GOTO GETDATAQ
+13 ;
+14 IF SCTYPE="TEAM"
DO TEAM
GOTO GETDATAQ
+15 ;
+16 IF SCTYPE="PRACTITIONER"
DO PRAC
GOTO GETDATAQ
+17 ;
+18 IF SCTYPE="ROLE"
DO ROLE
GOTO GETDATAQ
+19 ;
+20 IF SCTYPE="CLINIC"
DO CLIN
GOTO GETDATAQ
+21 ;
+22 IF SCTYPE="USERCLASS"
DO USER
GOTO GETDATAQ
+23 ;
GETDATAQ QUIT
+1 ;
CHK(SCX,SCLEN) ; -- check if text matches user input
+1 QUIT SCX=""!($EXTRACT(SCX,1,SCLEN)'=SCTEXT)
+2 ;
BACK(X) ; -- backup one char for scanning
+1 QUIT $SELECT(X="":"",$LENGTH(X)=1:$CHAR($ASCII(X)-1)_$CHAR(122),1:$EXTRACT(X,1,$LENGTH(X)-1)_$CHAR($ASCII($EXTRACT(X,$LENGTH(X)))-1)_$CHAR(122))
+2 ;
DIV ; -- get institution file entries
+1 NEW SCI,Y,SCX,SCLEN,SCINC
+2 SET SCI=0
SET SCINC=0
SET SCX=$$BACK(SCTEXT)
SET SCLEN=$LENGTH(SCTEXT)
+3 FOR
SET SCI=$ORDER(^SCTM(404.51,"AINST",SCI))
if 'SCI
QUIT
Begin DoDot:1
+4 SET Y=SCI
SET SC0=$GET(^DIC(4,Y,0))
+5 if $$CHK($PIECE(SC0,U),SCLEN)
QUIT
+6 DO SET($PIECE(SC0,U)_U_SCTYPE_U_SCI,.SCINC,SCDATA)
End DoDot:1
+7 QUIT
+8 ;
TEAM ; -- get team file entries
+1 NEW SCI,Y,SCX,SCLEN,SCINC,VAUTD
+2 SET SCI=0
SET SCINC=0
SET SCX=$$BACK(SCTEXT)
SET SCLEN=$LENGTH(SCTEXT)
+3 DO VAUTD(.SCSELS,.VAUTD)
+4 FOR
SET SCX=$ORDER(^SCTM(404.51,"B",SCX))
if $$CHK(SCX,SCLEN)
QUIT
Begin DoDot:1
+5 FOR
SET SCI=$ORDER(^SCTM(404.51,"B",SCX,SCI))
if 'SCI
QUIT
Begin DoDot:2
+6 SET Y=SCI
SET SC0=$GET(^SCTM(404.51,Y,0))
+7 IF $DATA(VAUTD(+$PIECE(^(0),U,7)))
DO SET($PIECE(SC0,U)_U_SCTYPE_U_SCI,.SCINC,SCDATA)
End DoDot:2
End DoDot:1
+8 QUIT
+9 ;
PRAC ; -- get practitioner entries
+1 NEW SCI,Y,SCX,SCLEN,SCINC,VAUTT
+2 SET SCI=0
SET SCINC=0
SET SCX=$$BACK(SCTEXT)
SET SCLEN=$LENGTH(SCTEXT)
+3 DO VAUTT(.SCSELS,.VAUTT)
+4 FOR
SET SCX=$ORDER(^VA(200,"B",SCX))
if $$CHK(SCX,SCLEN)
QUIT
Begin DoDot:1
+5 FOR
SET SCI=$ORDER(^VA(200,"B",SCX,SCI))
if 'SCI
QUIT
Begin DoDot:2
+6 SET Y=SCI
SET SC0=$GET(^VA(200,Y,0))
+7 IF $DATA(VAUTT)
IF $$PRACS^SCRPU1()
DO SET($PIECE(SC0,U)_U_SCTYPE_U_SCI,.SCINC,SCDATA)
End DoDot:2
End DoDot:1
+8 QUIT
+9 ;
ROLE ; -- get standard role file entries
+1 NEW SCI,Y,SCX,SCLEN,SCINC,VAUTT
+2 SET SCI=0
SET SCINC=0
SET SCX=$$BACK(SCTEXT)
SET SCLEN=$LENGTH(SCTEXT)
+3 DO VAUTT(.SCSELS,.VAUTT)
+4 FOR
SET SCX=$ORDER(^SD(403.46,"B",SCX))
if $$CHK(SCX,SCLEN)
QUIT
Begin DoDot:1
+5 FOR
SET SCI=$ORDER(^SD(403.46,"B",SCX,SCI))
if 'SCI
QUIT
Begin DoDot:2
+6 SET Y=SCI
SET SC0=$GET(^SD(403.46,SCI,0))
+7 IF $DATA(VAUTT)
IF $$RL^SCRPU1()
DO SET($PIECE(SC0,U)_U_SCTYPE_U_SCI,.SCINC,SCDATA)
End DoDot:2
End DoDot:1
+8 QUIT
+9 ;
CLIN ; -- get clinic entries
+1 NEW SCI,Y,SCX,SCLEN,SCINC,VAUTD,VAUTT,SCLIN
+2 SET SCLIN="^TMP($J,""PCMM"",""SCLIN"")"
+3 KILL @SCLIN
+4 SET SCI=0
SET SCINC=0
SET SCLEN=$LENGTH(SCTEXT)
+5 IF SCRPTID=2
Begin DoDot:1
+6 QUIT
End DoDot:1
+7 IF '$TEST
Begin DoDot:1
+8 DO VAUTT(.SCSELS,.VAUTT)
End DoDot:1
+9 FOR SCXREF="B","C","TEAMS"
SET SCX=$$BACK(SCTEXT)
Begin DoDot:1
+10 FOR
SET SCX=$ORDER(^SC(SCXREF,SCX))
if $$CHK(SCX,SCLEN)
QUIT
Begin DoDot:2
+11 FOR
SET SCI=$ORDER(^SC(SCXREF,SCX,SCI))
if 'SCI
QUIT
IF '$DATA(@SCLIN@(SCI))
Begin DoDot:3
+12 SET Y=SCI
SET SC0=$GET(^SC(Y,0))
+13 IF SCRPTID=2
IF $$CLSC2^SCRPU1()
DO SET($PIECE(SC0,U)_U_SCTYPE_U_SCI,.SCINC,SCDATA)
SET @SCLIN@(SCI)=""
+14 IF SCRPTID'=2
IF $DATA(VAUTT)
IF $$CLSC^SCRPU1()
DO SET($PIECE(SC0,U)_U_SCTYPE_U_SCI,.SCINC,SCDATA)
End DoDot:3
End DoDot:2
End DoDot:1
if SCTEXT=""
QUIT
+15 KILL @SCLIN
+16 QUIT
+17 ;
USER ; -- get user class file entries
+1 NEW SCI,Y,SCX,SCLEN,SCINC,VAUTT
+2 SET SCI=0
SET SCINC=0
SET SCX=$$BACK(SCTEXT)
SET SCLEN=$LENGTH(SCTEXT)
+3 DO VAUTT(.SCSELS,.VAUTT)
+4 FOR
SET SCX=$ORDER(^USR(8930,"B",SCX))
if $$CHK(SCX,SCLEN)
QUIT
Begin DoDot:1
+5 FOR
SET SCI=$ORDER(^USR(8930,"B",SCX,SCI))
if 'SCI
QUIT
Begin DoDot:2
+6 SET Y=SCI
SET SC0=$GET(^USR(8930,SCI,0))
+7 IF $DATA(VAUTT)
IF $$USRCL^SCRPU1()
DO SET($PIECE(SC0,U)_U_SCTYPE_U_SCI,.SCINC,SCDATA)
End DoDot:2
End DoDot:1
+8 QUIT
+9 ;
VAUTD(SCSELS,VAUTD) ; -- build division util array
+1 NEW I,X
+2 FOR I=1:1
SET X=$GET(SCSELS(I))
if X=""
QUIT
IF $PIECE(X,U,2)="DIVISION"
SET VAUTD(+$PIECE(X,U,3))=$PIECE(X,U)
+3 if $DATA(VAUTD)
SET VAUTD=0
+4 QUIT
+5 ;
VAUTT(SCSELS,VAUTT) ; -- build team util array
+1 NEW I,X
+2 IF SCRPTID=3
SET VAUTT=1
GOTO VAUTTQ
+3 FOR I=1:1
SET X=$GET(SCSELS(I))
if X=""
QUIT
IF $PIECE(X,U,2)="TEAM"
SET VAUTT(+$PIECE(X,U,3))=$PIECE(X,U)
+4 if $DATA(VAUTT)
SET VAUTT=0
VAUTTQ QUIT
+1 ;
SET(X,INC,SCDATA) ; -- set value in return array
+1 SET INC=$GET(INC)+1
SET @SCDATA@(INC)=X
+2 QUIT
+3 ;
