- SCMCDDR0 ;ALB/ART - FileMan FIND^DIC DBS Call for PCMM Web RPCs ;01/22/2014
- ;;5.3;Scheduling;**603**;Aug 13, 1993;Build 79
- ;
- ;This routine was copied from DDR0. 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)
- ;
- ;DDR0 ;SF/DCM-FileMan Delphi Components' RPCs ;4/28/98 10:52
- ;;22.0;VA FileMan;;Mar 30, 1999
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- QUIT
- ;
- FINDC(SCDATA,SC) ; -- broker callback to get list data
- N SCFILE,SCIENS,SCFLDS,SCFLAGS,SCVAL,SCMAX,SCXREF,SCSCRN,SCID,SCROOT,SCERR,SCRSLT,SCOPT,SCOUT,DIERR
- ; -- parse array to parameters
- D PARSE(.SC)
- S SCOUT=""
- D FIND^DIC(SCFILE,SCIENS,SCFLDS,SCFLAGS,SCVAL,SCMAX,SCXREF,SCSCRN,SCID,SCOUT,"SCERR")
- I $G(SCFLAGS)["P" D
- . Q:'$D(^TMP("DILIST",$J))
- . N COUNT S COUNT=^TMP("DILIST",$J,0) Q:'COUNT D 1
- . I XWBAPVER>1 S ^(.3)="[MAP]",^TMP("DILIST",$J,.4)=^TMP("DILIST",$J,0,"MAP")
- . K ^TMP("DILIST",$J,0) S ^(.5)="[BEGIN_diDATA]",^(COUNT+1)="[END_diDATA]"
- . Q
- I $G(SCFLAGS)'["P" D
- . Q:'$D(^TMP("DILIST",$J))
- . N COUNT S COUNT=^TMP("DILIST",$J,0) Q:'COUNT
- . D 1,UNPACKED
- . Q
- D 3,4
- Q
- 1 Q:'$P(COUNT,U,3)
- S ^TMP("DILIST",$J,.1)="[Misc]",^(.2)="MORE"
- Q
- 3 I $D(DIERR) D ERROR
- Q
- 4 S SCDATA=$NA(^TMP("DILIST",$J))
- 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"),"*")
- S SCVAL=$G(SC("VALUE"))
- S SCXREF=$G(SC("XREF"))
- S SCSCRN=$G(SC("SCREEN"))
- S SCID=$G(SC("ID"))
- S SCROOT=$G(SC("ROOT"))
- 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 ;
- K ^TMP("DILIST",$J,0)
- S ^TMP("DILIST",$J,.5)="[BEGIN_diDATA]" K ^TMP("DILIST",$J,1)
- S ^TMP("DILIST",$J,2,.1)="BEGIN_IENs",^(COUNT+1)="END_IENs"
- I SCFLDS]"",$D(^TMP("DILIST",$J,"ID")) D
- . N Z,FLD,FLDCNT S Z=0,FLD="",FLDCNT=0
- . 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",^(.1)=FLD_U_FLDCNT,^(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)
- I $G(SCOPT)["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 $G(SCOPT)'["WID" K ^TMP("DILIST",$J,"ID","WRITE")
- S ^TMP("DILIST",$J,"IDZ")="[END_diDATA]"
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCMCDDR0 3728 printed Mar 13, 2025@21:45:05 Page 2
- SCMCDDR0 ;ALB/ART - FileMan FIND^DIC DBS Call for PCMM Web RPCs ;01/22/2014
- +1 ;;5.3;Scheduling;**603**;Aug 13, 1993;Build 79
- +2 ;
- +3 ;This routine was copied from DDR0. 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 ;
- +8 ;DDR0 ;SF/DCM-FileMan Delphi Components' RPCs ;4/28/98 10:52
- +9 ;;22.0;VA FileMan;;Mar 30, 1999
- +10 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +11 ;
- +12 QUIT
- +13 ;
- FINDC(SCDATA,SC) ; -- broker callback to get list data
- +1 NEW SCFILE,SCIENS,SCFLDS,SCFLAGS,SCVAL,SCMAX,SCXREF,SCSCRN,SCID,SCROOT,SCERR,SCRSLT,SCOPT,SCOUT,DIERR
- +2 ; -- parse array to parameters
- +3 DO PARSE(.SC)
- +4 SET SCOUT=""
- +5 DO FIND^DIC(SCFILE,SCIENS,SCFLDS,SCFLAGS,SCVAL,SCMAX,SCXREF,SCSCRN,SCID,SCOUT,"SCERR")
- +6 IF $GET(SCFLAGS)["P"
- Begin DoDot:1
- +7 if '$DATA(^TMP("DILIST",$JOB))
- QUIT
- +8 NEW COUNT
- SET COUNT=^TMP("DILIST",$JOB,0)
- if 'COUNT
- QUIT
- DO 1
- +9 IF XWBAPVER>1
- SET ^(.3)="[MAP]"
- SET ^TMP("DILIST",$JOB,.4)=^TMP("DILIST",$JOB,0,"MAP")
- +10 KILL ^TMP("DILIST",$JOB,0)
- SET ^(.5)="[BEGIN_diDATA]"
- SET ^(COUNT+1)="[END_diDATA]"
- +11 QUIT
- End DoDot:1
- +12 IF $GET(SCFLAGS)'["P"
- Begin DoDot:1
- +13 if '$DATA(^TMP("DILIST",$JOB))
- QUIT
- +14 NEW COUNT
- SET COUNT=^TMP("DILIST",$JOB,0)
- if 'COUNT
- QUIT
- +15 DO 1
- DO UNPACKED
- +16 QUIT
- End DoDot:1
- +17 DO 3
- DO 4
- +18 QUIT
- 1 if '$PIECE(COUNT,U,3)
- QUIT
- +1 SET ^TMP("DILIST",$JOB,.1)="[Misc]"
- SET ^(.2)="MORE"
- +2 QUIT
- 3 IF $DATA(DIERR)
- DO ERROR
- +1 QUIT
- 4 SET SCDATA=$NAME(^TMP("DILIST",$JOB))
- +1 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 SET SCVAL=$GET(SC("VALUE"))
- +7 SET SCXREF=$GET(SC("XREF"))
- +8 SET SCSCRN=$GET(SC("SCREEN"))
- +9 SET SCID=$GET(SC("ID"))
- +10 SET SCROOT=$GET(SC("ROOT"))
- +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
- UNPACKED ;
- +1 KILL ^TMP("DILIST",$JOB,0)
- +2 SET ^TMP("DILIST",$JOB,.5)="[BEGIN_diDATA]"
- KILL ^TMP("DILIST",$JOB,1)
- +3 SET ^TMP("DILIST",$JOB,2,.1)="BEGIN_IENs"
- SET ^(COUNT+1)="END_IENs"
- +4 IF SCFLDS]""
- IF $DATA(^TMP("DILIST",$JOB,"ID"))
- Begin DoDot:1
- +5 NEW Z,FLD,FLDCNT
- SET Z=0
- SET FLD=""
- SET FLDCNT=0
- +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"
- SET ^(.1)=FLD_U_FLDCNT
- SET ^(COUNT+1)="END_IDVALUES"
- End DoDot:1
- +9 IF '$TEST
- Begin DoDot:1
- +10 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
- +11 IF $GET(SCOPT)["WID"
- IF $DATA(^TMP("DILIST",$JOB,"ID","WRITE"))
- Begin DoDot:1
- +12 NEW Z,N,I,IEN,WIDCNT
- SET (N,I)=0
- +13 MERGE Z=^TMP("DILIST",$JOB,"ID","WRITE")
- KILL ^TMP("DILIST",$JOB,"ID","WRITE")
- +14 SET ^TMP("DILIST",$JOB,"ID","WID",0)="BEGIN_WIDVALUES"
- SET N=N+1
- +15 FOR
- SET I=$ORDER(Z(I))
- if 'I
- QUIT
- SET IEN=$GET(^TMP("DILIST",$JOB,2,I))
- Begin DoDot:2
- +16 NEW J
- SET (J,WIDCNT)=0
- FOR
- SET J=$ORDER(Z(I,J))
- if 'J
- QUIT
- SET WIDCNT=WIDCNT+1
- +17 SET ^TMP("DILIST",$JOB,"ID","WID",N)="WID"_U_IEN_U_WIDCNT
- SET N=N+1
- +18 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
- +19 SET ^TMP("DILIST",$JOB,"ID","WID",N)="END_WIDVALUES"
- End DoDot:1
- +20 IF $GET(SCOPT)'["WID"
- KILL ^TMP("DILIST",$JOB,"ID","WRITE")
- +21 SET ^TMP("DILIST",$JOB,"IDZ")="[END_diDATA]"
- +22 QUIT
