SCMCDDR ;ALB/ART - FileMan LIST^DIC DBS Call for PCMM Web RPCs ;02/26/2015
;;5.3;Scheduling;**603**;Aug 13, 1993;Build 79
;
;This routine was copied from DDR. PCMM/R needs a new RPC that has .11 APP PROXY ALLOWED set to Yes
;
;Public, Supported ICRs
; #2051 - Database Server API: Lookup Utilities (DIC)
; #2238 - CHANGE RPC RETURN TYPE (XWBLIB)
; #2239 - XWBAPVER -- RPC VERSION
;
;DDR ;ALB/MJK,SF/DCM-FileMan Delphi Components' RPCs ;4/28/98 10:38
;;22.0;VA FileMan;;Mar 30, 1999
;Per VHA Directive 10-93-142, this routine should not be modified.
;
QUIT
;
LISTC(SCDATA,SC) ; -- broker callback to get list data
N SCFILE,SCIENS,SCFLDS,SCMAX,SCFROM,SCPART,SCXREF,SCSCRN,SCID,SCVAL,SCERR,SCRSLT,SCFLD,SCFLAGS,SCOPT,SCOUT,DIERR
; -- parse array to parameters
D PARSE(.SC)
S SCPART=$TR(SCPART,$C(13)_$C(10),"")
; -- get specific field criteria
IF $G(SC("DDFILE")),$G(SC("DDFIELD")),$D(^DD(SC("DDFILE"),SC("DDFIELD"),12.1)) D
. N DIC X ^(12.1) S:$D(DIC("S")) SCSCRN=DIC("S")
I 'XWBAPVER D V0 Q
I XWBAPVER>0 D V1 Q
Q
;
DIC ;
D LIST^DIC(SCFILE,SCIENS,SCFLDS,SCFLAGS,SCMAX,.SCFROM,SCPART,SCXREF,SCSCRN,SCID,SCOUT,"SCERR")
Q
;
V0 ;
S SCOUT="SCRSLT",SCFLAGS=$G(SCFLAGS)_"P",SCFLDS=$G(SCFLDS)_";@"
D DIC
N Y,I,N S N=0
I $G(SCFROM)]"" D SET("[Misc]"),SET("MORE"_U_SCFROM_U_SCFROM("IEN"))
I $D(SCRSLT("DILIST")) D
. D SET("[Data]")
. S I=0 F S I=$O(SCRSLT("DILIST",I)) Q:'I D SET(SCRSLT("DILIST",I,0))
IF $D(SCERR) D SET("[Errors]")
S X=$$STYPE("ARRAY")
Q
;
STYPE(X,WRAP) ;For backward compatability only
I $D(WRAP) Q $$RTRNFMT^XWBLIB($G(X),WRAP)
Q $$RTRNFMT^XWBLIB(X)
;
V1 ;
S SCOUT=""
I XWBAPVER=1,SCFLAGS["P" S SCFLAGS=SCFLAGS_"S" ;only P flag is sent from client for V1 of FMCD
D DIC
I $G(SCFLAGS)["P" D Q
. I $D(^TMP("DILIST",$J)) D
. . N END S END=+^TMP("DILIST",$J,0)
. . I XWBAPVER>1 S ^(.3)="[MAP]",^TMP("DILIST",$J,.4)=^TMP("DILIST",$J,0,"MAP")
. . K ^TMP("DILIST",$J,0) S ^(.5)="[BEGIN_diDATA]",^(END+1)="[END_diDATA]"
. D 11,31
. S SCDATA=$NA(^TMP("DILIST",$J))
. Q
I $G(SCFLAGS)'["P" D 11,UNPACKED,31 S SCDATA=$NA(^TMP("DILIST",$J)) Q
Q
11 ;
I $G(SCFROM)]"" S ^TMP("DILIST",$J,.1)="[Misc]",^(.2)="MORE"_U_SCFROM_U_SCFROM("IEN")_$S(XWBAPVER>1:U_$P($G(^TMP("DILIST",$J,0)),U,4),1:"")
Q
31 ;
I $D(DIERR) D ERROR
Q
SET(X) ;
S N=N+1
S SCDATA(N)=X
Q
PARSE(SC) ; -- array parsing
S SCFILE=$G(SC("FILE"))
S SCIENS=$G(SC("IENS"))
S SCFLDS=$G(SC("FIELDS"))
S SCFLAGS=$G(SC("FLAGS"))
S SCMAX=$G(SC("MAX"),"*")
M SCFROM=SC("FROM")
S SCPART=$G(SC("PART"))
S SCXREF=$G(SC("XREF"))
S SCSCRN=$G(SC("SCREEN"))
S SCID=$G(SC("ID"))
S SCOPT=$G(SC("OPTIONS"))
Q
ERROR ;
N I S I=1
D Z("[BEGIN_diERRORS]")
N A S A=0 F S A=$O(SCERR("DIERR",A)) Q:'A D
. N HD,PARAM,B,C,TEXT,TXTCNT,D,FILE,FIELD,IENS,%
. S HD=SCERR("DIERR",A)
. I $D(SCERR("DIERR",A,"PARAM",0)) D
. . S (B,D)=0 F C=1:1 S B=$O(SCERR("DIERR",A,"PARAM",B)) Q:B="" D
. . . I B="FILE" S FILE=SCERR("DIERR",A,"PARAM","FILE")
. . . I B="FIELD" S FIELD=SCERR("DIERR",A,"PARAM","FIELD")
. . . I B="IENS" S IENS=SCERR("DIERR",A,"PARAM","IENS")
. . . S D=D+1,PARAM(D)=B_U_SCERR("DIERR",A,"PARAM",B)
. S C=0 F S C=$O(SCERR("DIERR",A,"TEXT",C)) Q:'C S TEXT(C)=SCERR("DIERR",A,"TEXT",C),TXTCNT=C
. S HD=HD_U_TXTCNT_U_$G(FILE)_U_$G(IENS)_U_$G(FIELD)_U_$G(D) D Z(HD)
. S B=0 F S B=$O(PARAM(B)) Q:'B S %=PARAM(B) D Z(%)
. S B=0 F S B=$O(TEXT(B)) Q:'B S %=TEXT(B) D Z(%)
. Q
D Z("[END_diERRORS]")
Q
Z(%) ;
S ^TMP("DILIST",$J,"ZERR",I)=%,I=I+1
Q
;
UNPACKED ;
Q:'$D(^TMP("DILIST",$J))
N COUNT,IXCNT
S COUNT=+^TMP("DILIST",$J,0) Q:'COUNT
I XWBAPVER>1 S ^TMP("DILIST",$J,.3)="[MAP]",^TMP("DILIST",$J,.4)=^TMP("DILIST",$J,0,"MAP")
K ^TMP("DILIST",$J,0)
S ^TMP("DILIST",$J,.5)="[BEGIN_diDATA]"
I XWBAPVER=1 D IX1
D IENS,FLDS,WID,END
Q
IX1 ;
I SCOPT["IX",$D(^TMP("DILIST",$J,1)) D
. S ^TMP("DILIST",$J,1,COUNT+1)="END_IXVALUES" D S ^(.1)="BEGIN_IXVALUES",^(.2)=IXCNT
. . N Z S Z=0,IXCNT=0 I $G(^TMP("DILIST",$J,1,1))]"" S IXCNT=1 Q
. . F S Z=$O(^TMP("DILIST",$J,1,1,Z)) Q:'Z S IXCNT=IXCNT+1
I SCOPT'["IX" K ^TMP("DILIST",$J,1)
Q
IENS ;
I $D(^TMP("DILIST",$J,2)) D
. S ^TMP("DILIST",$J,2,.1)="BEGIN_IENs",^(COUNT+1)="END_IENs"
Q
FLDS ;
I SCFLDS]"",$D(^TMP("DILIST",$J,"ID")) D
. N Z,FLD,FLDCNT S FLD="",(Z,FLDCNT,I)=0
. ;I XWBAPVER>1,SCFLDS["IX" D
. ;. F S I=$O(^TMP("DILIST",$J,"ID",1,0,I)) Q:'I S IXCNT=IXCNT+1
. ;. S ^TMP("DILIST",$J,"ID",0,0)="IXCNT="_IXCNT Q
. F S Z=$O(^TMP("DILIST",$J,"ID",1,Z)) Q:'Z S FLD=FLD_Z_";",FLDCNT=FLDCNT+1
. Q:'FLDCNT
. S ^TMP("DILIST",$J,"ID",0)="BEGIN_IDVALUES"
. I XWBAPVER=1 S ^TMP("DILIST",$J,"ID",.1)=FLD_U_FLDCNT
. S ^TMP("DILIST",$J,"ID",COUNT+1)="END_IDVALUES"
E D
. N Z S Z=0 F S Z=$O(^TMP("DILIST",$J,"ID",Z)) Q:'Z K ^TMP("DILIST",$J,"ID",Z)
Q
WID ;
I (SCOPT["WID")!(SCFLDS["WID"),$D(^TMP("DILIST",$J,"ID","WRITE")) D
. N Z,N,I,IEN,WIDCNT S (N,I)=0
. M Z=^TMP("DILIST",$J,"ID","WRITE") K ^TMP("DILIST",$J,"ID","WRITE")
. S ^TMP("DILIST",$J,"ID","WID",0)="BEGIN_WIDVALUES",N=N+1
. F S I=$O(Z(I)) Q:'I S IEN=$G(^TMP("DILIST",$J,2,I)) D
. . N J S (J,WIDCNT)=0 F S J=$O(Z(I,J)) Q:'J S WIDCNT=WIDCNT+1
. . S ^TMP("DILIST",$J,"ID","WID",N)="WID"_U_IEN_U_WIDCNT,N=N+1
. . N J S J=0 F J=1:1:WIDCNT S ^TMP("DILIST",$J,"ID","WID",N)=Z(I,J),N=N+1
. S ^TMP("DILIST",$J,"ID","WID",N)="END_WIDVALUES"
I (SCOPT'["WID")&(SCFLDS'["WID") K ^TMP("DILIST",$J,"ID","WRITE")
Q
END ;
S ^TMP("DILIST",$J,"IDZ")="[END_diDATA]"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCMCDDR 5592 printed Apr 09, 2024@21:42:04 Page 2
SCMCDDR ;ALB/ART - FileMan LIST^DIC DBS Call for PCMM Web RPCs ;02/26/2015
+1 ;;5.3;Scheduling;**603**;Aug 13, 1993;Build 79
+2 ;
+3 ;This routine was copied from DDR. PCMM/R needs a new RPC that has .11 APP PROXY ALLOWED set to Yes
+4 ;
+5 ;Public, Supported ICRs
+6 ; #2051 - Database Server API: Lookup Utilities (DIC)
+7 ; #2238 - CHANGE RPC RETURN TYPE (XWBLIB)
+8 ; #2239 - XWBAPVER -- RPC VERSION
+9 ;
+10 ;DDR ;ALB/MJK,SF/DCM-FileMan Delphi Components' RPCs ;4/28/98 10:38
+11 ;;22.0;VA FileMan;;Mar 30, 1999
+12 ;Per VHA Directive 10-93-142, this routine should not be modified.
+13 ;
+14 QUIT
+15 ;
LISTC(SCDATA,SC) ; -- broker callback to get list data
+1 NEW SCFILE,SCIENS,SCFLDS,SCMAX,SCFROM,SCPART,SCXREF,SCSCRN,SCID,SCVAL,SCERR,SCRSLT,SCFLD,SCFLAGS,SCOPT,SCOUT,DIERR
+2 ; -- parse array to parameters
+3 DO PARSE(.SC)
+4 SET SCPART=$TRANSLATE(SCPART,$CHAR(13)_$CHAR(10),"")
+5 ; -- get specific field criteria
+6 IF $GET(SC("DDFILE"))
IF $GET(SC("DDFIELD"))
IF $DATA(^DD(SC("DDFILE"),SC("DDFIELD"),12.1))
Begin DoDot:1
+7 NEW DIC
XECUTE ^(12.1)
if $DATA(DIC("S"))
SET SCSCRN=DIC("S")
End DoDot:1
+8 IF 'XWBAPVER
DO V0
QUIT
+9 IF XWBAPVER>0
DO V1
QUIT
+10 QUIT
+11 ;
DIC ;
+1 DO LIST^DIC(SCFILE,SCIENS,SCFLDS,SCFLAGS,SCMAX,.SCFROM,SCPART,SCXREF,SCSCRN,SCID,SCOUT,"SCERR")
+2 QUIT
+3 ;
V0 ;
+1 SET SCOUT="SCRSLT"
SET SCFLAGS=$GET(SCFLAGS)_"P"
SET SCFLDS=$GET(SCFLDS)_";@"
+2 DO DIC
+3 NEW Y,I,N
SET N=0
+4 IF $GET(SCFROM)]""
DO SET("[Misc]")
DO SET("MORE"_U_SCFROM_U_SCFROM("IEN"))
+5 IF $DATA(SCRSLT("DILIST"))
Begin DoDot:1
+6 DO SET("[Data]")
+7 SET I=0
FOR
SET I=$ORDER(SCRSLT("DILIST",I))
if 'I
QUIT
DO SET(SCRSLT("DILIST",I,0))
End DoDot:1
+8 IF $DATA(SCERR)
DO SET("[Errors]")
+9 SET X=$$STYPE("ARRAY")
+10 QUIT
+11 ;
STYPE(X,WRAP) ;For backward compatability only
+1 IF $DATA(WRAP)
QUIT $$RTRNFMT^XWBLIB($GET(X),WRAP)
+2 QUIT $$RTRNFMT^XWBLIB(X)
+3 ;
V1 ;
+1 SET SCOUT=""
+2 ;only P flag is sent from client for V1 of FMCD
IF XWBAPVER=1
IF SCFLAGS["P"
SET SCFLAGS=SCFLAGS_"S"
+3 DO DIC
+4 IF $GET(SCFLAGS)["P"
Begin DoDot:1
+5 IF $DATA(^TMP("DILIST",$JOB))
Begin DoDot:2
+6 NEW END
SET END=+^TMP("DILIST",$JOB,0)
+7 IF XWBAPVER>1
SET ^(.3)="[MAP]"
SET ^TMP("DILIST",$JOB,.4)=^TMP("DILIST",$JOB,0,"MAP")
+8 KILL ^TMP("DILIST",$JOB,0)
SET ^(.5)="[BEGIN_diDATA]"
SET ^(END+1)="[END_diDATA]"
End DoDot:2
+9 DO 11
DO 31
+10 SET SCDATA=$NAME(^TMP("DILIST",$JOB))
+11 QUIT
End DoDot:1
QUIT
+12 IF $GET(SCFLAGS)'["P"
DO 11
DO UNPACKED
DO 31
SET SCDATA=$NAME(^TMP("DILIST",$JOB))
QUIT
+13 QUIT
11 ;
+1 IF $GET(SCFROM)]""
SET ^TMP("DILIST",$JOB,.1)="[Misc]"
SET ^(.2)="MORE"_U_SCFROM_U_SCFROM("IEN")_$SELECT(XWBAPVER>1:U_$PIECE($GET(^TMP("DILIST",$JOB,0)),U,4),1:"")
+2 QUIT
31 ;
+1 IF $DATA(DIERR)
DO ERROR
+2 QUIT
SET(X) ;
+1 SET N=N+1
+2 SET SCDATA(N)=X
+3 QUIT
PARSE(SC) ; -- array parsing
+1 SET SCFILE=$GET(SC("FILE"))
+2 SET SCIENS=$GET(SC("IENS"))
+3 SET SCFLDS=$GET(SC("FIELDS"))
+4 SET SCFLAGS=$GET(SC("FLAGS"))
+5 SET SCMAX=$GET(SC("MAX"),"*")
+6 MERGE SCFROM=SC("FROM")
+7 SET SCPART=$GET(SC("PART"))
+8 SET SCXREF=$GET(SC("XREF"))
+9 SET SCSCRN=$GET(SC("SCREEN"))
+10 SET SCID=$GET(SC("ID"))
+11 SET SCOPT=$GET(SC("OPTIONS"))
+12 QUIT
ERROR ;
+1 NEW I
SET I=1
+2 DO Z("[BEGIN_diERRORS]")
+3 NEW A
SET A=0
FOR
SET A=$ORDER(SCERR("DIERR",A))
if 'A
QUIT
Begin DoDot:1
+4 NEW HD,PARAM,B,C,TEXT,TXTCNT,D,FILE,FIELD,IENS,%
+5 SET HD=SCERR("DIERR",A)
+6 IF $DATA(SCERR("DIERR",A,"PARAM",0))
Begin DoDot:2
+7 SET (B,D)=0
FOR C=1:1
SET B=$ORDER(SCERR("DIERR",A,"PARAM",B))
if B=""
QUIT
Begin DoDot:3
+8 IF B="FILE"
SET FILE=SCERR("DIERR",A,"PARAM","FILE")
+9 IF B="FIELD"
SET FIELD=SCERR("DIERR",A,"PARAM","FIELD")
+10 IF B="IENS"
SET IENS=SCERR("DIERR",A,"PARAM","IENS")
+11 SET D=D+1
SET PARAM(D)=B_U_SCERR("DIERR",A,"PARAM",B)
End DoDot:3
End DoDot:2
+12 SET C=0
FOR
SET C=$ORDER(SCERR("DIERR",A,"TEXT",C))
if 'C
QUIT
SET TEXT(C)=SCERR("DIERR",A,"TEXT",C)
SET TXTCNT=C
+13 SET HD=HD_U_TXTCNT_U_$GET(FILE)_U_$GET(IENS)_U_$GET(FIELD)_U_$GET(D)
DO Z(HD)
+14 SET B=0
FOR
SET B=$ORDER(PARAM(B))
if 'B
QUIT
SET %=PARAM(B)
DO Z(%)
+15 SET B=0
FOR
SET B=$ORDER(TEXT(B))
if 'B
QUIT
SET %=TEXT(B)
DO Z(%)
+16 QUIT
End DoDot:1
+17 DO Z("[END_diERRORS]")
+18 QUIT
Z(%) ;
+1 SET ^TMP("DILIST",$JOB,"ZERR",I)=%
SET I=I+1
+2 QUIT
+3 ;
UNPACKED ;
+1 if '$DATA(^TMP("DILIST",$JOB))
QUIT
+2 NEW COUNT,IXCNT
+3 SET COUNT=+^TMP("DILIST",$JOB,0)
if 'COUNT
QUIT
+4 IF XWBAPVER>1
SET ^TMP("DILIST",$JOB,.3)="[MAP]"
SET ^TMP("DILIST",$JOB,.4)=^TMP("DILIST",$JOB,0,"MAP")
+5 KILL ^TMP("DILIST",$JOB,0)
+6 SET ^TMP("DILIST",$JOB,.5)="[BEGIN_diDATA]"
+7 IF XWBAPVER=1
DO IX1
+8 DO IENS
DO FLDS
DO WID
DO END
+9 QUIT
IX1 ;
+1 IF SCOPT["IX"
IF $DATA(^TMP("DILIST",$JOB,1))
Begin DoDot:1
+2 SET ^TMP("DILIST",$JOB,1,COUNT+1)="END_IXVALUES"
Begin DoDot:2
+3 NEW Z
SET Z=0
SET IXCNT=0
IF $GET(^TMP("DILIST",$JOB,1,1))]""
SET IXCNT=1
QUIT
+4 FOR
SET Z=$ORDER(^TMP("DILIST",$JOB,1,1,Z))
if 'Z
QUIT
SET IXCNT=IXCNT+1
End DoDot:2
SET ^(.1)="BEGIN_IXVALUES"
SET ^(.2)=IXCNT
End DoDot:1
+5 IF SCOPT'["IX"
KILL ^TMP("DILIST",$JOB,1)
+6 QUIT
IENS ;
+1 IF $DATA(^TMP("DILIST",$JOB,2))
Begin DoDot:1
+2 SET ^TMP("DILIST",$JOB,2,.1)="BEGIN_IENs"
SET ^(COUNT+1)="END_IENs"
End DoDot:1
+3 QUIT
FLDS ;
+1 IF SCFLDS]""
IF $DATA(^TMP("DILIST",$JOB,"ID"))
Begin DoDot:1
+2 NEW Z,FLD,FLDCNT
SET FLD=""
SET (Z,FLDCNT,I)=0
+3 ;I XWBAPVER>1,SCFLDS["IX" D
+4 ;. F S I=$O(^TMP("DILIST",$J,"ID",1,0,I)) Q:'I S IXCNT=IXCNT+1
+5 ;. S ^TMP("DILIST",$J,"ID",0,0)="IXCNT="_IXCNT Q
+6 FOR
SET Z=$ORDER(^TMP("DILIST",$JOB,"ID",1,Z))
if 'Z
QUIT
SET FLD=FLD_Z_";"
SET FLDCNT=FLDCNT+1
+7 if 'FLDCNT
QUIT
+8 SET ^TMP("DILIST",$JOB,"ID",0)="BEGIN_IDVALUES"
+9 IF XWBAPVER=1
SET ^TMP("DILIST",$JOB,"ID",.1)=FLD_U_FLDCNT
+10 SET ^TMP("DILIST",$JOB,"ID",COUNT+1)="END_IDVALUES"
End DoDot:1
+11 IF '$TEST
Begin DoDot:1
+12 NEW Z
SET Z=0
FOR
SET Z=$ORDER(^TMP("DILIST",$JOB,"ID",Z))
if 'Z
QUIT
KILL ^TMP("DILIST",$JOB,"ID",Z)
End DoDot:1
+13 QUIT
WID ;
+1 IF (SCOPT["WID")!(SCFLDS["WID")
IF $DATA(^TMP("DILIST",$JOB,"ID","WRITE"))
Begin DoDot:1
+2 NEW Z,N,I,IEN,WIDCNT
SET (N,I)=0
+3 MERGE Z=^TMP("DILIST",$JOB,"ID","WRITE")
KILL ^TMP("DILIST",$JOB,"ID","WRITE")
+4 SET ^TMP("DILIST",$JOB,"ID","WID",0)="BEGIN_WIDVALUES"
SET N=N+1
+5 FOR
SET I=$ORDER(Z(I))
if 'I
QUIT
SET IEN=$GET(^TMP("DILIST",$JOB,2,I))
Begin DoDot:2
+6 NEW J
SET (J,WIDCNT)=0
FOR
SET J=$ORDER(Z(I,J))
if 'J
QUIT
SET WIDCNT=WIDCNT+1
+7 SET ^TMP("DILIST",$JOB,"ID","WID",N)="WID"_U_IEN_U_WIDCNT
SET N=N+1
+8 NEW J
SET J=0
FOR J=1:1:WIDCNT
SET ^TMP("DILIST",$JOB,"ID","WID",N)=Z(I,J)
SET N=N+1
End DoDot:2
+9 SET ^TMP("DILIST",$JOB,"ID","WID",N)="END_WIDVALUES"
End DoDot:1
+10 IF (SCOPT'["WID")&(SCFLDS'["WID")
KILL ^TMP("DILIST",$JOB,"ID","WRITE")
+11 QUIT
END ;
+1 SET ^TMP("DILIST",$JOB,"IDZ")="[END_diDATA]"
+2 QUIT
