- DDR2 ;ALB/MJK-FileMan Delphi Components' RPCs ;4/20/98 11:38
- ;;22.0;VA FileMan;;Mar 30, 1999
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- Q
- ;
- FIND1C(DDRDATA,DDR) ; DDR FIND1 rpc callback
- N DDRFILE,DDRIENS,DDRFLAGS,DDRVAL,DDRXREF,DDRSCRN,DDRERR,A,IEN,N
- D PARSE(.DDR) S DDRVAL=$G(DDR("VALUE"))
- S A=$$FIND1^DIC(DDRFILE,DDRIENS,DDRFLAGS,DDRVAL,DDRXREF,DDRSCRN,"DDRERR")
- S A=$S($G(DIERR):"",1:A)
- S N=0 D SET(A)
- I $G(DIERR) D ERROR Q
- I $G(DDROPT)["R" S IEN=$S($G(DDRIENS)]"":A_DDRIENS,1:A_",") D RECALL^DILFD(DDRFILE,IEN,DUZ)
- Q
- ;
- GETSC(DDRDATA,DDR) ; DDR GETS ENTRY DATA rpc callback
- N DDRFILE,DDRIENS,DDRFLDS,DDRFLAGS,DDROPT,DDRRSLT,DDRERR
- N DDRXREF,DDRSCRN,N
- D PARSE(.DDR)
- D GETS^DIQ(DDRFILE,DDRIENS,DDRFLDS,DDRFLAGS,"DDRRSLT","DDRERR")
- S N=0
- I '$D(DDROPT) D 1,2 Q
- I $G(DDROPT)["U" D 11,21
- I $G(DDROPT)["?" D HLP
- Q
- 1 I $D(DDRRSLT) D
- . N DDRFIELD,X,J
- . D SET("[Data]")
- . S DDRFIELD=0 F S DDRFIELD=$O(DDRRSLT(DDRFILE,DDRIENS,DDRFIELD)) Q:'DDRFIELD D
- . . ;Do not remove stripping of ',' from IENS in line below if this code should work with T11 (21.1T1) of FM components.
- . . S X=DDRFILE_"^"_$E(DDRIENS,1,$L(DDRIENS)-1)_"^"_DDRFIELD_"^"
- . . ; -- below call to $$GET1 is too slow...working w/FM team for speed
- . . ;IF $$GET1^DID(DDRFILE,DDRFIELD,"","TYPE")="WORD-PROCESSING" D
- . . ;IF $P($G(^DD(DDRFILE,DDRFIELD,0)),U,4)[";0" D <<Replaced by more generic check below.
- . . I $P($G(^DD(+$P($G(^DD(DDRFILE,DDRFIELD,0)),U,2),.01,0)),U,2)["W" D
- . . . D SET(X_"[WORD PROCESSING]")
- . . . S J=0 F S J=$O(DDRRSLT(DDRFILE,DDRIENS,DDRFIELD,J)) Q:'J D
- . . . . D SET(DDRRSLT(DDRFILE,DDRIENS,DDRFIELD,J))
- . . . D SET("$$END$$")
- . . E D
- . . . D SET(X_$G(DDRRSLT(DDRFILE,DDRIENS,DDRFIELD,"I"))_"^"_$G(DDRRSLT(DDRFILE,DDRIENS,DDRFIELD,"E")))
- Q
- 11 N HD,I,E,B,J,K
- D SET("[BEGIN_diDATA]")
- S HD=DDRFILE_U_$E(DDRIENS,1,$L(DDRIENS)-1)
- S I=DDRFLAGS["I",E=DDRFLAGS["E",B=(I&E)
- S DDRFIELD=0 F S DDRFIELD=$O(DDRRSLT(DDRFILE,DDRIENS,DDRFIELD)) Q:'DDRFIELD D
- . I $P($G(^DD(+$P($G(^DD(DDRFILE,DDRFIELD,0)),U,2),.01,0)),U,2)["W" D Q
- . . S (K,J)=0 F S K=$O(DDRRSLT(DDRFILE,DDRIENS,DDRFIELD,K)) Q:'K S J=J+1
- . . D SET(HD_U_DDRFIELD_U_"W"_U_J)
- . . S J=0 F S J=$O(DDRRSLT(DDRFILE,DDRIENS,DDRFIELD,J)) Q:'J D SET(DDRRSLT(DDRFILE,DDRIENS,DDRFIELD,J))
- . . Q
- . S FLG=$S(B:"B",I:"I",1:"E")
- . D SET(HD_U_DDRFIELD_U_FLG)
- . I B D SET(DDRRSLT(DDRFILE,DDRIENS,DDRFIELD,"E")),SET(DDRRSLT(DDRFILE,DDRIENS,DDRFIELD,"I")) Q
- . I E D SET(DDRRSLT(DDRFILE,DDRIENS,DDRFIELD,"E")) Q
- . I I D SET(DDRRSLT(DDRFILE,DDRIENS,DDRFIELD,"I")) Q
- D SET("[END_diDATA]")
- Q
- 2 IF $D(DDRERR) D SET("[ERROR]")
- Q
- 21 I $D(DIERR) D ERROR
- Q
- SET(X) ;
- S N=N+1
- S DDRDATA(N)=X
- Q
- HLP ;
- N FLD,FLG,Z,%
- S FLD=0,FLG="?"
- D SET("[BEGIN_diHELP]")
- F Z=1:1 S FLD=+$P(DDRFLDS,";",Z) Q:'FLD D HELP(DDRFILE,DDRIENS,FLD,FLG)
- D SET("[END_diHELP]")
- Q
- ;
- GETHLPC(DDRDATA,DDR) ; DDR GET DD HELP rpc callback
- N DDRFILE,DDRFIELD,DDRFLGS,N
- S DDRFILE=$G(DDR("FILE"))
- S DDRFIELD=$G(DDR("FIELD"))
- S DDRFLGS=$G(DDR("FLAGS"))
- S N=0
- D SET("[BEGIN_diHELP]")
- D HELP(DDRFILE,"",DDRFIELD,DDRFLGS)
- D SET("[END_diHELP]")
- Q
- ;
- HELP(FILE,IENS,FIELD,FLGS) ;
- N DDRHLP,HD,A
- D HELP^DIE(FILE,IENS,FIELD,FLGS,"DDRHLP")
- Q:'$D(DDRHLP("DIHELP"))
- S HD=FILE_U_FIELD_U_"?"_U_DDRHLP("DIHELP") D SET(HD)
- S A=0 F S A=$O(DDRHLP("DIHELP",A)) Q:'A D SET(DDRHLP("DIHELP",A))
- Q
- ERROR ;
- D SET("[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 SET(HD)
- . S B=0 F S B=$O(PARAM(B)) Q:'B S %=PARAM(B) D SET(%)
- . S B=0 F S B=$O(TEXT(B)) Q:'B S %=TEXT(B) D SET(%)
- . Q
- D SET("[END_diERRORS]")
- Q
- PARSE(DDR) ;
- S DDRFILE=$G(DDR("FILE"))
- S DDRIENS=$G(DDR("IENS"))
- S DDRFLDS=$G(DDR("FIELDS"))
- S DDRFLAGS=$G(DDR("FLAGS"))
- S DDRXREF=$G(DDR("XREF"))
- S DDRSCRN=$G(DDR("SCREEN"))
- S:$D(DDR("OPTIONS")) DDROPT=DDR("OPTIONS")
- Q
- DDR2 ;ALB/MJK-FileMan Delphi Components' RPCs ;4/20/98 11: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
- +5 ;
- FIND1C(DDRDATA,DDR) ; DDR FIND1 rpc callback
- +1 NEW DDRFILE,DDRIENS,DDRFLAGS,DDRVAL,DDRXREF,DDRSCRN,DDRERR,A,IEN,N
- +2 DO PARSE(.DDR)
- SET DDRVAL=$GET(DDR("VALUE"))
- +3 SET A=$$FIND1^DIC(DDRFILE,DDRIENS,DDRFLAGS,DDRVAL,DDRXREF,DDRSCRN,"DDRERR")
- +4 SET A=$SELECT($GET(DIERR):"",1:A)
- +5 SET N=0
- DO SET(A)
- +6 IF $GET(DIERR)
- DO ERROR
- QUIT
- +7 IF $GET(DDROPT)["R"
- SET IEN=$SELECT($GET(DDRIENS)]"":A_DDRIENS,1:A_",")
- DO RECALL^DILFD(DDRFILE,IEN,DUZ)
- +8 QUIT
- +9 ;
- GETSC(DDRDATA,DDR) ; DDR GETS ENTRY DATA rpc callback
- +1 NEW DDRFILE,DDRIENS,DDRFLDS,DDRFLAGS,DDROPT,DDRRSLT,DDRERR
- +2 NEW DDRXREF,DDRSCRN,N
- +3 DO PARSE(.DDR)
- +4 DO GETS^DIQ(DDRFILE,DDRIENS,DDRFLDS,DDRFLAGS,"DDRRSLT","DDRERR")
- +5 SET N=0
- +6 IF '$DATA(DDROPT)
- DO 1
- DO 2
- QUIT
- +7 IF $GET(DDROPT)["U"
- DO 11
- DO 21
- +8 IF $GET(DDROPT)["?"
- DO HLP
- +9 QUIT
- 1 IF $DATA(DDRRSLT)
- Begin DoDot:1
- +1 NEW DDRFIELD,X,J
- +2 DO SET("[Data]")
- +3 SET DDRFIELD=0
- FOR
- SET DDRFIELD=$ORDER(DDRRSLT(DDRFILE,DDRIENS,DDRFIELD))
- IF 'DDRFIELD
- QUIT
- Begin DoDot:2
- +4 ;Do not remove stripping of ',' from IENS in line below if this code should work with T11 (21.1T1) of FM components.
- +5 SET X=DDRFILE_"^"_$EXTRACT(DDRIENS,1,$LENGTH(DDRIENS)-1)_"^"_DDRFIELD_"^"
- +6 ; -- below call to $$GET1 is too slow...working w/FM team for speed
- +7 ;IF $$GET1^DID(DDRFILE,DDRFIELD,"","TYPE")="WORD-PROCESSING" D
- +8 ;IF $P($G(^DD(DDRFILE,DDRFIELD,0)),U,4)[";0" D <<Replaced by more generic check below.
- +9 IF $PIECE($GET(^DD(+$PIECE($GET(^DD(DDRFILE,DDRFIELD,0)),U,2),.01,0)),U,2)["W"
- Begin DoDot:3
- +10 DO SET(X_"[WORD PROCESSING]")
- +11 SET J=0
- FOR
- SET J=$ORDER(DDRRSLT(DDRFILE,DDRIENS,DDRFIELD,J))
- IF 'J
- QUIT
- Begin DoDot:4
- +12 DO SET(DDRRSLT(DDRFILE,DDRIENS,DDRFIELD,J))
- End DoDot:4
- +13 DO SET("$$END$$")
- End DoDot:3
- +14 IF '$TEST
- Begin DoDot:3
- +15 DO SET(X_$GET(DDRRSLT(DDRFILE,DDRIENS,DDRFIELD,"I"))_"^"_$GET(DDRRSLT(DDRFILE,DDRIENS,DDRFIELD,"E")))
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +16 QUIT
- 11 NEW HD,I,E,B,J,K
- +1 DO SET("[BEGIN_diDATA]")
- +2 SET HD=DDRFILE_U_$EXTRACT(DDRIENS,1,$LENGTH(DDRIENS)-1)
- +3 SET I=DDRFLAGS["I"
- SET E=DDRFLAGS["E"
- SET B=(I&E)
- +4 SET DDRFIELD=0
- FOR
- SET DDRFIELD=$ORDER(DDRRSLT(DDRFILE,DDRIENS,DDRFIELD))
- IF 'DDRFIELD
- QUIT
- Begin DoDot:1
- +5 IF $PIECE($GET(^DD(+$PIECE($GET(^DD(DDRFILE,DDRFIELD,0)),U,2),.01,0)),U,2)["W"
- Begin DoDot:2
- +6 SET (K,J)=0
- FOR
- SET K=$ORDER(DDRRSLT(DDRFILE,DDRIENS,DDRFIELD,K))
- IF 'K
- QUIT
- SET J=J+1
- +7 DO SET(HD_U_DDRFIELD_U_"W"_U_J)
- +8 SET J=0
- FOR
- SET J=$ORDER(DDRRSLT(DDRFILE,DDRIENS,DDRFIELD,J))
- IF 'J
- QUIT
- DO SET(DDRRSLT(DDRFILE,DDRIENS,DDRFIELD,J))
- +9 QUIT
- End DoDot:2
- QUIT
- +10 SET FLG=$SELECT(B:"B",I:"I",1:"E")
- +11 DO SET(HD_U_DDRFIELD_U_FLG)
- +12 IF B
- DO SET(DDRRSLT(DDRFILE,DDRIENS,DDRFIELD,"E"))
- DO SET(DDRRSLT(DDRFILE,DDRIENS,DDRFIELD,"I"))
- QUIT
- +13 IF E
- DO SET(DDRRSLT(DDRFILE,DDRIENS,DDRFIELD,"E"))
- QUIT
- +14 IF I
- DO SET(DDRRSLT(DDRFILE,DDRIENS,DDRFIELD,"I"))
- QUIT
- End DoDot:1
- +15 DO SET("[END_diDATA]")
- +16 QUIT
- 2 IF $DATA(DDRERR)
- DO SET("[ERROR]")
- +1 QUIT
- 21 IF $DATA(DIERR)
- DO ERROR
- +1 QUIT
- SET(X) ;
- +1 SET N=N+1
- +2 SET DDRDATA(N)=X
- +3 QUIT
- HLP ;
- +1 NEW FLD,FLG,Z,%
- +2 SET FLD=0
- SET FLG="?"
- +3 DO SET("[BEGIN_diHELP]")
- +4 FOR Z=1:1
- SET FLD=+$PIECE(DDRFLDS,";",Z)
- IF 'FLD
- QUIT
- DO HELP(DDRFILE,DDRIENS,FLD,FLG)
- +5 DO SET("[END_diHELP]")
- +6 QUIT
- +7 ;
- GETHLPC(DDRDATA,DDR) ; DDR GET DD HELP rpc callback
- +1 NEW DDRFILE,DDRFIELD,DDRFLGS,N
- +2 SET DDRFILE=$GET(DDR("FILE"))
- +3 SET DDRFIELD=$GET(DDR("FIELD"))
- +4 SET DDRFLGS=$GET(DDR("FLAGS"))
- +5 SET N=0
- +6 DO SET("[BEGIN_diHELP]")
- +7 DO HELP(DDRFILE,"",DDRFIELD,DDRFLGS)
- +8 DO SET("[END_diHELP]")
- +9 QUIT
- +10 ;
- HELP(FILE,IENS,FIELD,FLGS) ;
- +1 NEW DDRHLP,HD,A
- +2 DO HELP^DIE(FILE,IENS,FIELD,FLGS,"DDRHLP")
- +3 IF '$DATA(DDRHLP("DIHELP"))
- QUIT
- +4 SET HD=FILE_U_FIELD_U_"?"_U_DDRHLP("DIHELP")
- DO SET(HD)
- +5 SET A=0
- FOR
- SET A=$ORDER(DDRHLP("DIHELP",A))
- IF 'A
- QUIT
- DO SET(DDRHLP("DIHELP",A))
- +6 QUIT
- ERROR ;
- +1 DO SET("[BEGIN_diERRORS]")
- +2 NEW A
- SET A=0
- FOR
- SET A=$ORDER(DDRERR("DIERR",A))
- IF 'A
- QUIT
- Begin DoDot:1
- +3 NEW HD,PARAM,B,C,TEXT,TXTCNT,D,FILE,FIELD,IENS
- +4 SET HD=DDRERR("DIERR",A)
- +5 IF $DATA(DDRERR("DIERR",A,"PARAM",0))
- Begin DoDot:2
- +6 SET (B,D)=0
- FOR C=1:1
- SET B=$ORDER(DDRERR("DIERR",A,"PARAM",B))
- IF B=""
- QUIT
- Begin DoDot:3
- +7 IF B="FILE"
- SET FILE=DDRERR("DIERR",A,"PARAM","FILE")
- +8 IF B="FIELD"
- SET FIELD=DDRERR("DIERR",A,"PARAM","FIELD")
- +9 IF B="IENS"
- SET IENS=DDRERR("DIERR",A,"PARAM","IENS")
- +10 SET D=D+1
- SET PARAM(D)=B_U_DDRERR("DIERR",A,"PARAM",B)
- End DoDot:3
- End DoDot:2
- +11 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
- +12 SET HD=HD_U_TXTCNT_U_$GET(FILE)_U_$GET(IENS)_U_$GET(FIELD)_U_$GET(D)
- DO SET(HD)
- +13 SET B=0
- FOR
- SET B=$ORDER(PARAM(B))
- IF 'B
- QUIT
- SET %=PARAM(B)
- DO SET(%)
- +14 SET B=0
- FOR
- SET B=$ORDER(TEXT(B))
- IF 'B
- QUIT
- SET %=TEXT(B)
- DO SET(%)
- +15 QUIT
- End DoDot:1
- +16 DO SET("[END_diERRORS]")
- +17 QUIT
- PARSE(DDR) ;
- +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 DDRXREF=$GET(DDR("XREF"))
- +6 SET DDRSCRN=$GET(DDR("SCREEN"))
- +7 IF $DATA(DDR("OPTIONS"))
- SET DDROPT=DDR("OPTIONS")
- +8 QUIT
