- 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.
- ;
- Q
- LISTC(DDRDATA,DDR) ; -- broker callback to get list data
- N DDRFILE,DDRIENS,DDRFLDS,DDRMAX,DDRFROM,DDRPART,DDRXREF,DDRSCRN,DDRID,DDRVAL,DDRERR,DDRRSLT,DDRFLD,DDRFLAGS,DDROPT,DDROUT
- ; -- parse array to parameters
- D PARSE(.DDR)
- S DDRPART=$TR(DDRPART,$C(13)_$C(10),"")
- ; -- get specific field criteria
- IF $G(DDR("DDFILE")),$G(DDR("DDFIELD")),$D(^DD(DDR("DDFILE"),DDR("DDFIELD"),12.1)) D
- . N DIC X ^(12.1) S:$D(DIC("S")) DDRSCRN=DIC("S")
- I 'XWBAPVER D V0 Q
- I XWBAPVER>0 D V1 Q
- Q
- ;
- DIC D LIST^DIC(DDRFILE,DDRIENS,DDRFLDS,DDRFLAGS,DDRMAX,.DDRFROM,DDRPART,DDRXREF,DDRSCRN,DDRID,DDROUT,"DDRERR")
- Q
- ;
- V0 S DDROUT="DDRRSLT",DDRFLAGS=$G(DDRFLAGS)_"P",DDRFLDS=$G(DDRFLDS)_";@"
- D DIC
- N Y,I,N S N=0
- I $G(DDRFROM)]"" D SET("[Misc]"),SET("MORE"_U_DDRFROM_U_DDRFROM("IEN"))
- I $D(DDRRSLT("DILIST")) D
- . D SET("[Data]")
- . S I=0 F S I=$O(DDRRSLT("DILIST",I)) Q:'I D SET(DDRRSLT("DILIST",I,0))
- IF $D(DDRERR) D SET("[Errors]")
- S X=$$STYPE^XWBTCPC("ARRAY")
- Q
- ;
- V1 S DDROUT=""
- I XWBAPVER=1,DDRFLAGS["P" S DDRFLAGS=DDRFLAGS_"S" ;only P flag is sent from client for V1 of FMCD
- D DIC
- I $G(DDRFLAGS)["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 DDRDATA=$NA(^TMP("DILIST",$J))
- . Q
- I $G(DDRFLAGS)'["P" D 11,UNPACKED,31 S DDRDATA=$NA(^TMP("DILIST",$J)) Q
- Q
- 11 I $G(DDRFROM)]"" S ^TMP("DILIST",$J,.1)="[Misc]",^(.2)="MORE"_U_DDRFROM_U_DDRFROM("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 DDRDATA(N)=X
- Q
- PARSE(DDR) ; -- array parsing
- S DDRFILE=$G(DDR("FILE"))
- S DDRIENS=$G(DDR("IENS"))
- S DDRFLDS=$G(DDR("FIELDS"))
- S DDRFLAGS=$G(DDR("FLAGS"))
- S DDRMAX=$G(DDR("MAX"),"*")
- M DDRFROM=DDR("FROM")
- S DDRPART=$G(DDR("PART"))
- S DDRXREF=$G(DDR("XREF"))
- S DDRSCRN=$G(DDR("SCREEN"))
- S DDRID=$G(DDR("ID"))
- S DDROPT=$G(DDR("OPTIONS"))
- Q
- ERROR ;
- N I S I=1
- D Z("[BEGIN_diERRORS]")
- N A S A=0 F S A=$O(DDRERR("DIERR",A)) Q:'A D
- . N HD,PARAM,B,C,TEXT,TXTCNT,D,FILE,FIELD,IENS
- . S HD=DDRERR("DIERR",A)
- . I $D(DDRERR("DIERR",A,"PARAM",0)) D
- . . S (B,D)=0 F C=1:1 S B=$O(DDRERR("DIERR",A,"PARAM",B)) Q:B="" D
- . . . I B="FILE" S FILE=DDRERR("DIERR",A,"PARAM","FILE")
- . . . I B="FIELD" S FIELD=DDRERR("DIERR",A,"PARAM","FIELD")
- . . . I B="IENS" S IENS=DDRERR("DIERR",A,"PARAM","IENS")
- . . . S D=D+1,PARAM(D)=B_U_DDRERR("DIERR",A,"PARAM",B)
- . S C=0 F S C=$O(DDRERR("DIERR",A,"TEXT",C)) Q:'C S TEXT(C)=DDRERR("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 DDROPT["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 DDROPT'["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 DDRFLDS]"",$D(^TMP("DILIST",$J,"ID")) D
- . N Z,FLD,FLDCNT S FLD="",(Z,FLDCNT,I)=0
- . ;I XWBAPVER>1,DDRFLDS["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 (DDROPT["WID")!(DDRFLDS["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 (DDROPT'["WID")&(DDRFLDS'["WID") K ^TMP("DILIST",$J,"ID","WRITE")
- Q
- END S ^TMP("DILIST",$J,"IDZ")="[END_diDATA]"
- Q
- DDR ;ALB/MJK,SF/DCM-FileMan Delphi Components' RPCs ;4/28/98 10:38
- +1 ;;22.0;VA FileMan;;Mar 30, 1999
- +2 ;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 ;
- +4 QUIT
- LISTC(DDRDATA,DDR) ; -- broker callback to get list data
- +1 NEW DDRFILE,DDRIENS,DDRFLDS,DDRMAX,DDRFROM,DDRPART,DDRXREF,DDRSCRN,DDRID,DDRVAL,DDRERR,DDRRSLT,DDRFLD,DDRFLAGS,DDROPT,DDROUT
- +2 ; -- parse array to parameters
- +3 DO PARSE(.DDR)
- +4 SET DDRPART=$TRANSLATE(DDRPART,$CHAR(13)_$CHAR(10),"")
- +5 ; -- get specific field criteria
- +6 IF $GET(DDR("DDFILE"))
- IF $GET(DDR("DDFIELD"))
- IF $DATA(^DD(DDR("DDFILE"),DDR("DDFIELD"),12.1))
- Begin DoDot:1
- +7 NEW DIC
- XECUTE ^(12.1)
- IF $DATA(DIC("S"))
- SET DDRSCRN=DIC("S")
- End DoDot:1
- +8 IF 'XWBAPVER
- DO V0
- QUIT
- +9 IF XWBAPVER>0
- DO V1
- QUIT
- +10 QUIT
- +11 ;
- DIC DO LIST^DIC(DDRFILE,DDRIENS,DDRFLDS,DDRFLAGS,DDRMAX,.DDRFROM,DDRPART,DDRXREF,DDRSCRN,DDRID,DDROUT,"DDRERR")
- +1 QUIT
- +2 ;
- V0 SET DDROUT="DDRRSLT"
- SET DDRFLAGS=$GET(DDRFLAGS)_"P"
- SET DDRFLDS=$GET(DDRFLDS)_";@"
- +1 DO DIC
- +2 NEW Y,I,N
- SET N=0
- +3 IF $GET(DDRFROM)]""
- DO SET("[Misc]")
- DO SET("MORE"_U_DDRFROM_U_DDRFROM("IEN"))
- +4 IF $DATA(DDRRSLT("DILIST"))
- Begin DoDot:1
- +5 DO SET("[Data]")
- +6 SET I=0
- FOR
- SET I=$ORDER(DDRRSLT("DILIST",I))
- IF 'I
- QUIT
- DO SET(DDRRSLT("DILIST",I,0))
- End DoDot:1
- +7 IF $DATA(DDRERR)
- DO SET("[Errors]")
- +8 SET X=$$STYPE^XWBTCPC("ARRAY")
- +9 QUIT
- +10 ;
- V1 SET DDROUT=""
- +1 ;only P flag is sent from client for V1 of FMCD
- IF XWBAPVER=1
- IF DDRFLAGS["P"
- SET DDRFLAGS=DDRFLAGS_"S"
- +2 DO DIC
- +3 IF $GET(DDRFLAGS)["P"
- Begin DoDot:1
- +4 IF $DATA(^TMP("DILIST",$JOB))
- Begin DoDot:2
- +5 NEW END
- SET END=+^TMP("DILIST",$JOB,0)
- +6 IF XWBAPVER>1
- SET ^(.3)="[MAP]"
- SET ^TMP("DILIST",$JOB,.4)=^TMP("DILIST",$JOB,0,"MAP")
- +7 KILL ^TMP("DILIST",$JOB,0)
- SET ^(.5)="[BEGIN_diDATA]"
- SET ^(END+1)="[END_diDATA]"
- End DoDot:2
- +8 DO 11
- DO 31
- +9 SET DDRDATA=$NAME(^TMP("DILIST",$JOB))
- +10 QUIT
- End DoDot:1
- QUIT
- +11 IF $GET(DDRFLAGS)'["P"
- DO 11
- DO UNPACKED
- DO 31
- SET DDRDATA=$NAME(^TMP("DILIST",$JOB))
- QUIT
- +12 QUIT
- 11 IF $GET(DDRFROM)]""
- SET ^TMP("DILIST",$JOB,.1)="[Misc]"
- SET ^(.2)="MORE"_U_DDRFROM_U_DDRFROM("IEN")_$SELECT(XWBAPVER>1:U_$PIECE($GET(^TMP("DILIST",$JOB,0)),U,4),1:"")
- +1 QUIT
- 31 IF $DATA(DIERR)
- DO ERROR
- +1 QUIT
- SET(X) ;
- +1 SET N=N+1
- +2 SET DDRDATA(N)=X
- +3 QUIT
- PARSE(DDR) ; -- array parsing
- +1 SET DDRFILE=$GET(DDR("FILE"))
- +2 SET DDRIENS=$GET(DDR("IENS"))
- +3 SET DDRFLDS=$GET(DDR("FIELDS"))
- +4 SET DDRFLAGS=$GET(DDR("FLAGS"))
- +5 SET DDRMAX=$GET(DDR("MAX"),"*")
- +6 MERGE DDRFROM=DDR("FROM")
- +7 SET DDRPART=$GET(DDR("PART"))
- +8 SET DDRXREF=$GET(DDR("XREF"))
- +9 SET DDRSCRN=$GET(DDR("SCREEN"))
- +10 SET DDRID=$GET(DDR("ID"))
- +11 SET DDROPT=$GET(DDR("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(DDRERR("DIERR",A))
- IF 'A
- QUIT
- Begin DoDot:1
- +4 NEW HD,PARAM,B,C,TEXT,TXTCNT,D,FILE,FIELD,IENS
- +5 SET HD=DDRERR("DIERR",A)
- +6 IF $DATA(DDRERR("DIERR",A,"PARAM",0))
- Begin DoDot:2
- +7 SET (B,D)=0
- FOR C=1:1
- SET B=$ORDER(DDRERR("DIERR",A,"PARAM",B))
- IF B=""
- QUIT
- Begin DoDot:3
- +8 IF B="FILE"
- SET FILE=DDRERR("DIERR",A,"PARAM","FILE")
- +9 IF B="FIELD"
- SET FIELD=DDRERR("DIERR",A,"PARAM","FIELD")
- +10 IF B="IENS"
- SET IENS=DDRERR("DIERR",A,"PARAM","IENS")
- +11 SET D=D+1
- SET PARAM(D)=B_U_DDRERR("DIERR",A,"PARAM",B)
- End DoDot:3
- End DoDot:2
- +12 SET C=0
- FOR
- SET C=$ORDER(DDRERR("DIERR",A,"TEXT",C))
- IF 'C
- QUIT
- SET TEXT(C)=DDRERR("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
- QUIT
- +2 ;
- 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 IF DDROPT["IX"
- IF $DATA(^TMP("DILIST",$JOB,1))
- Begin DoDot:1
- +1 SET ^TMP("DILIST",$JOB,1,COUNT+1)="END_IXVALUES"
- Begin DoDot:2
- +2 NEW Z
- SET Z=0
- SET IXCNT=0
- IF $GET(^TMP("DILIST",$JOB,1,1))]""
- SET IXCNT=1
- QUIT
- +3 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
- +4 IF DDROPT'["IX"
- KILL ^TMP("DILIST",$JOB,1)
- +5 QUIT
- IENS IF $DATA(^TMP("DILIST",$JOB,2))
- Begin DoDot:1
- +1 SET ^TMP("DILIST",$JOB,2,.1)="BEGIN_IENs"
- SET ^(COUNT+1)="END_IENs"
- End DoDot:1
- +2 QUIT
- FLDS IF DDRFLDS]""
- IF $DATA(^TMP("DILIST",$JOB,"ID"))
- Begin DoDot:1
- +1 NEW Z,FLD,FLDCNT
- SET FLD=""
- SET (Z,FLDCNT,I)=0
- +2 ;I XWBAPVER>1,DDRFLDS["IX" D
- +3 ;. F S I=$O(^TMP("DILIST",$J,"ID",1,0,I)) Q:'I S IXCNT=IXCNT+1
- +4 ;. S ^TMP("DILIST",$J,"ID",0,0)="IXCNT="_IXCNT Q
- +5 FOR
- SET Z=$ORDER(^TMP("DILIST",$JOB,"ID",1,Z))
- IF 'Z
- QUIT
- SET FLD=FLD_Z_";"
- SET FLDCNT=FLDCNT+1
- +6 IF 'FLDCNT
- QUIT
- +7 SET ^TMP("DILIST",$JOB,"ID",0)="BEGIN_IDVALUES"
- +8 IF XWBAPVER=1
- SET ^TMP("DILIST",$JOB,"ID",.1)=FLD_U_FLDCNT
- +9 SET ^TMP("DILIST",$JOB,"ID",COUNT+1)="END_IDVALUES"
- End DoDot:1
- +10 IF '$TEST
- Begin DoDot:1
- +11 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
- +12 QUIT
- WID IF (DDROPT["WID")!(DDRFLDS["WID")
- IF $DATA(^TMP("DILIST",$JOB,"ID","WRITE"))
- Begin DoDot:1
- +1 NEW Z,N,I,IEN,WIDCNT
- SET (N,I)=0
- +2 MERGE Z=^TMP("DILIST",$JOB,"ID","WRITE")
- KILL ^TMP("DILIST",$JOB,"ID","WRITE")
- +3 SET ^TMP("DILIST",$JOB,"ID","WID",0)="BEGIN_WIDVALUES"
- SET N=N+1
- +4 FOR
- SET I=$ORDER(Z(I))
- IF 'I
- QUIT
- SET IEN=$GET(^TMP("DILIST",$JOB,2,I))
- Begin DoDot:2
- +5 NEW J
- SET (J,WIDCNT)=0
- FOR
- SET J=$ORDER(Z(I,J))
- IF 'J
- QUIT
- SET WIDCNT=WIDCNT+1
- +6 SET ^TMP("DILIST",$JOB,"ID","WID",N)="WID"_U_IEN_U_WIDCNT
- SET N=N+1
- +7 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
- +8 SET ^TMP("DILIST",$JOB,"ID","WID",N)="END_WIDVALUES"
- End DoDot:1
- +9 IF (DDROPT'["WID")&(DDRFLDS'["WID")
- KILL ^TMP("DILIST",$JOB,"ID","WRITE")
- +10 QUIT
- END SET ^TMP("DILIST",$JOB,"IDZ")="[END_diDATA]"
- +1 QUIT
