- DDR3 ;ALB/MJK,SF/DCM-FileMan Delphi Components' RPCs ;2/24/98 10:01
- ;;22.0;VA FileMan;;Mar 30, 1999
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- Q
- ;
- FILEC(DDRDATA,DDRMODE,DDRROOT,DDRFLAGS,DDRIENS) ; DDR FILER rpc callback
- N DDRRTN,DDRFDA,DDRERR,N,I
- D FDASET(.DDRROOT,.DDRFDA)
- ; -- set up placeholder DINUM's if any
- ; -- NOTE: Can't use until multiple arrays can be passed by broker
- I $D(DDRROOT("IENs")) M DDRIENS=DDRROOT("IENs")
- S I="" F S I=$O(DDRIENS(I)) Q:I="" S DDRRTN(+I)=+DDRIENS(I)
- IF DDRMODE="ADD" D
- . D UPDATE^DIE("","DDRFDA","DDRRTN","DDRERR")
- ELSE D
- . S DDRFLAGS=$S($D(DDRFLAGS):DDRFLAGS,1:"")
- . D FILE^DIE(DDRFLAGS,"DDRFDA","DDRERR")
- S N=0
- D SET("[Data]")
- ; -- send back info on entry #'s for placeholders
- S I=0 F S I=$O(DDRRTN(I)) Q:'I D SET("+"_I_","_U_DDRRTN(I))
- IF $D(DDRERR) D ERROR
- Q
- ;
- FDASET(DDRROOT,DDRFDA) ;
- N DDRFILE,DDRIEN,DDRFIELD,DDRVAL,DDRERR,I
- S I=0
- F S I=$O(DDRROOT(I)) Q:'I S X=DDRROOT(I) D
- . S DDRFILE=$P(X,U)
- . S DDRFIELD=$P(X,U,2)
- . S DDRIEN=$P(X,U,3)
- . S DDRVAL=$P(X,U,4,99)
- . D FDA^DILF(DDRFILE,DDRIEN_$S($E(DDRIEN,$L(DDRIEN))'=",":",",1:""),DDRFIELD,"",DDRVAL,"DDRFDA","DDRERR")
- Q
- ;
- VALC(DDRDATA,DDR) ; DDR VALIDATOR rpc callback
- N DDRFILE,DDRIENS,DDRFIELD,DDRVAL,DDRRSLT,DDRERR,DDRFLAGS,N
- S DDRFLAGS="EH"
- S DDRFILE=$G(DDR("FILE"))
- S DDRIENS=$G(DDR("IENS"))
- S DDRFIELD=$G(DDR("FIELD"))
- S DDRVAL=$G(DDR("VALUE"))
- D VAL^DIE(DDRFILE,DDRIENS,DDRFIELD,DDRFLAGS,DDRVAL,.DDRRSLT,"","DDRERR")
- S N=0
- D SET("[FILLER]")
- D SET("[Data]")
- D SET($G(DDRRSLT,U))
- D SET($G(DDRRSLT(0)))
- IF $D(DDRERR) D ERROR,HELP
- Q
- SET(X) ;
- S N=N+1
- S DDRDATA(N)=X
- Q
- HELP ;
- Q:'$D(DDRERR("DIHELP"))
- D SET("[BEGIN_diHELP]")
- S HD=DDRFILE_U_DDRFIELD_U_"?"_U_DDRERR("DIHELP") D SET(HD)
- N A S A=0 F S A=$O(DDRERR("DIHELP",A)) Q:'A D SET(DDRERR("DIHELP",A))
- D SET("[END_diHELP]")
- 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
- ;
- DDR3 ;ALB/MJK,SF/DCM-FileMan Delphi Components' RPCs ;2/24/98 10:01
- +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 ;
- FILEC(DDRDATA,DDRMODE,DDRROOT,DDRFLAGS,DDRIENS) ; DDR FILER rpc callback
- +1 NEW DDRRTN,DDRFDA,DDRERR,N,I
- +2 DO FDASET(.DDRROOT,.DDRFDA)
- +3 ; -- set up placeholder DINUM's if any
- +4 ; -- NOTE: Can't use until multiple arrays can be passed by broker
- +5 IF $DATA(DDRROOT("IENs"))
- MERGE DDRIENS=DDRROOT("IENs")
- +6 SET I=""
- FOR
- SET I=$ORDER(DDRIENS(I))
- IF I=""
- QUIT
- SET DDRRTN(+I)=+DDRIENS(I)
- +7 IF DDRMODE="ADD"
- Begin DoDot:1
- +8 DO UPDATE^DIE("","DDRFDA","DDRRTN","DDRERR")
- End DoDot:1
- +9 IF '$TEST
- Begin DoDot:1
- +10 SET DDRFLAGS=$SELECT($DATA(DDRFLAGS):DDRFLAGS,1:"")
- +11 DO FILE^DIE(DDRFLAGS,"DDRFDA","DDRERR")
- End DoDot:1
- +12 SET N=0
- +13 DO SET("[Data]")
- +14 ; -- send back info on entry #'s for placeholders
- +15 SET I=0
- FOR
- SET I=$ORDER(DDRRTN(I))
- IF 'I
- QUIT
- DO SET("+"_I_","_U_DDRRTN(I))
- +16 IF $DATA(DDRERR)
- DO ERROR
- +17 QUIT
- +18 ;
- FDASET(DDRROOT,DDRFDA) ;
- +1 NEW DDRFILE,DDRIEN,DDRFIELD,DDRVAL,DDRERR,I
- +2 SET I=0
- +3 FOR
- SET I=$ORDER(DDRROOT(I))
- IF 'I
- QUIT
- SET X=DDRROOT(I)
- Begin DoDot:1
- +4 SET DDRFILE=$PIECE(X,U)
- +5 SET DDRFIELD=$PIECE(X,U,2)
- +6 SET DDRIEN=$PIECE(X,U,3)
- +7 SET DDRVAL=$PIECE(X,U,4,99)
- +8 DO FDA^DILF(DDRFILE,DDRIEN_$SELECT($EXTRACT(DDRIEN,$LENGTH(DDRIEN))'=",":",",1:""),DDRFIELD,"",DDRVAL,"DDRFDA","DDRERR")
- End DoDot:1
- +9 QUIT
- +10 ;
- VALC(DDRDATA,DDR) ; DDR VALIDATOR rpc callback
- +1 NEW DDRFILE,DDRIENS,DDRFIELD,DDRVAL,DDRRSLT,DDRERR,DDRFLAGS,N
- +2 SET DDRFLAGS="EH"
- +3 SET DDRFILE=$GET(DDR("FILE"))
- +4 SET DDRIENS=$GET(DDR("IENS"))
- +5 SET DDRFIELD=$GET(DDR("FIELD"))
- +6 SET DDRVAL=$GET(DDR("VALUE"))
- +7 DO VAL^DIE(DDRFILE,DDRIENS,DDRFIELD,DDRFLAGS,DDRVAL,.DDRRSLT,"","DDRERR")
- +8 SET N=0
- +9 DO SET("[FILLER]")
- +10 DO SET("[Data]")
- +11 DO SET($GET(DDRRSLT,U))
- +12 DO SET($GET(DDRRSLT(0)))
- +13 IF $DATA(DDRERR)
- DO ERROR
- DO HELP
- +14 QUIT
- SET(X) ;
- +1 SET N=N+1
- +2 SET DDRDATA(N)=X
- +3 QUIT
- HELP ;
- +1 IF '$DATA(DDRERR("DIHELP"))
- QUIT
- +2 DO SET("[BEGIN_diHELP]")
- +3 SET HD=DDRFILE_U_DDRFIELD_U_"?"_U_DDRERR("DIHELP")
- DO SET(HD)
- +4 NEW A
- SET A=0
- FOR
- SET A=$ORDER(DDRERR("DIHELP",A))
- IF 'A
- QUIT
- DO SET(DDRERR("DIHELP",A))
- +5 DO SET("[END_diHELP]")
- +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
- +18 ;
