SCMCDDR2 ;ALB/ART - FileMan FIND1^DIC and GETS^DIQ DBS Call for PCMM Web RPCs ;02/04/2015
;;5.3;Scheduling;**603**;Aug 13, 1993;Build 79
;
;This routine was copied from DDR2.
;PCMM Web needs a new RPC that has .11 APP PROXY ALLOWED set to Yes
;
;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.
;
;Public, Supported ICRs
; #2051 - Database Server API: Lookup Utilities (DIC)
; #2053 - Data Base Server API: Editing Utilities (DIE)
; #2055 - Data Base Server API: Misc. Data Libaray Functions (DILFD)
; #2056 - Data Base Server API: Data Retriever Utilities (DIQ)
; #10154 - DESCRIPTOR BLOCK - ^DD
;
QUIT
;
FIND1C(SCDATA,SC) ; DDR FIND1 rpc callback
N SCFILE,SCIENS,SCFLAGS,SCVAL,SCXREF,SCSCRN,SCERR,A,IEN,N,DIERR
D PARSE(.SC) S SCVAL=$G(SC("VALUE"))
S A=$$FIND1^DIC(SCFILE,SCIENS,SCFLAGS,SCVAL,SCXREF,SCSCRN,"SCERR")
S A=$S($G(DIERR):"",1:A)
S N=0 D SET(A)
I $G(DIERR) D ERROR Q
I $G(SCOPT)["R" S IEN=$S($G(SCIENS)]"":A_SCIENS,1:A_",") D RECALL^DILFD(SCFILE,IEN,DUZ)
Q
;
GETSC(SCDATA,SC) ; DDR GETS ENTRY DATA rpc callback
N SCFILE,SCIENS,SCFLDS,SCFLAGS,SCOPT,SCRSLT,SCERR
N SCXREF,SCSCRN,N
D PARSE(.SC)
D GETS^DIQ(SCFILE,SCIENS,SCFLDS,SCFLAGS,"SCRSLT","SCERR")
S N=0
I '$D(SCOPT) D 1,2 Q
I $G(SCOPT)["U" D 11,21
I $G(SCOPT)["?" D HLP
Q
;
1 ;
I $D(SCRSLT) D
. N SCFIELD,X,J
. D SET("[Data]")
. S SCFIELD=0 F S SCFIELD=$O(SCRSLT(SCFILE,SCIENS,SCFIELD)) Q:'SCFIELD 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=SCFILE_"^"_$E(SCIENS,1,$L(SCIENS)-1)_"^"_SCFIELD_"^"
. . I $P($G(^DD(+$P($G(^DD(SCFILE,SCFIELD,0)),U,2),.01,0)),U,2)["W" D
. . . D SET(X_"[WORD PROCESSING]")
. . . S J=0 F S J=$O(SCRSLT(SCFILE,SCIENS,SCFIELD,J)) Q:'J D
. . . . D SET(SCRSLT(SCFILE,SCIENS,SCFIELD,J))
. . . D SET("$$END$$")
. . E D
. . . D SET(X_$G(SCRSLT(SCFILE,SCIENS,SCFIELD,"I"))_"^"_$G(SCRSLT(SCFILE,SCIENS,SCFIELD,"E")))
Q
;
11 ;
N HD,I,E,B,J,K
D SET("[BEGIN_diDATA]")
S HD=SCFILE_U_$E(SCIENS,1,$L(SCIENS)-1)
S I=SCFLAGS["I",E=SCFLAGS["E",B=(I&E)
S SCFIELD=0 F S SCFIELD=$O(SCRSLT(SCFILE,SCIENS,SCFIELD)) Q:'SCFIELD D
. I $P($G(^DD(+$P($G(^DD(SCFILE,SCFIELD,0)),U,2),.01,0)),U,2)["W" D Q
. . S (K,J)=0 F S K=$O(SCRSLT(SCFILE,SCIENS,SCFIELD,K)) Q:'K S J=J+1
. . D SET(HD_U_SCFIELD_U_"W"_U_J)
. . S J=0 F S J=$O(SCRSLT(SCFILE,SCIENS,SCFIELD,J)) Q:'J D SET(SCRSLT(SCFILE,SCIENS,SCFIELD,J))
. . Q
. S FLG=$S(B:"B",I:"I",1:"E")
. D SET(HD_U_SCFIELD_U_FLG)
. I B D SET(SCRSLT(SCFILE,SCIENS,SCFIELD,"E")),SET(SCRSLT(SCFILE,SCIENS,SCFIELD,"I")) Q
. I E D SET(SCRSLT(SCFILE,SCIENS,SCFIELD,"E")) Q
. I I D SET(SCRSLT(SCFILE,SCIENS,SCFIELD,"I")) Q
D SET("[END_diDATA]")
Q
;
2 ;
IF $D(SCERR) D SET("[ERROR]")
Q
;
21 ;
I $D(DIERR) D ERROR
Q
;
SET(X) ;
S N=N+1
S SCDATA(N)=X
Q
;
HLP ;
N FLD,FLG,Z,%
S FLD=0,FLG="?"
D SET("[BEGIN_diHELP]")
F Z=1:1 S FLD=+$P(SCFLDS,";",Z) Q:'FLD D HELP(SCFILE,SCIENS,FLD,FLG)
D SET("[END_diHELP]")
Q
;
GETHLPC(SCDATA,SC) ; SC GET DD HELP rpc callback
N SCFILE,SCFIELD,SCFLGS,N
S SCFILE=$G(SC("FILE"))
S SCFIELD=$G(SC("FIELD"))
S SCFLGS=$G(SC("FLAGS"))
S N=0
D SET("[BEGIN_diHELP]")
D HELP(SCFILE,"",SCFIELD,SCFLGS)
D SET("[END_diHELP]")
Q
;
HELP(FILE,IENS,FIELD,FLGS) ;
N SCHLP,HD,A
D HELP^DIE(FILE,IENS,FIELD,FLGS,"SCHLP")
Q:'$D(SCHLP("DIHELP"))
S HD=FILE_U_FIELD_U_"?"_U_SCHLP("DIHELP") D SET(HD)
S A=0 F S A=$O(SCHLP("DIHELP",A)) Q:'A D SET(SCHLP("DIHELP",A))
Q
;
ERROR ;
D SET("[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 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(SC) ;
S SCFILE=$G(SC("FILE"))
S SCIENS=$G(SC("IENS"))
S SCFLDS=$G(SC("FIELDS"))
S SCFLAGS=$G(SC("FLAGS"))
S SCXREF=$G(SC("XREF"))
S SCSCRN=$G(SC("SCREEN"))
S:$D(SC("OPTIONS")) SCOPT=SC("OPTIONS")
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSCMCDDR2 4751 printed Sep 23, 2025@20:16:32 Page 2
SCMCDDR2 ;ALB/ART - FileMan FIND1^DIC and GETS^DIQ DBS Call for PCMM Web RPCs ;02/04/2015
+1 ;;5.3;Scheduling;**603**;Aug 13, 1993;Build 79
+2 ;
+3 ;This routine was copied from DDR2.
+4 ;PCMM Web needs a new RPC that has .11 APP PROXY ALLOWED set to Yes
+5 ;
+6 ;DDR2 ;ALB/MJK-FileMan Delphi Components' RPCs ;4/20/98 11:38
+7 ;;22.0;VA FileMan;;Mar 30, 1999
+8 ;Per VHA Directive 10-93-142, this routine should not be modified.
+9 ;
+10 ;Public, Supported ICRs
+11 ; #2051 - Database Server API: Lookup Utilities (DIC)
+12 ; #2053 - Data Base Server API: Editing Utilities (DIE)
+13 ; #2055 - Data Base Server API: Misc. Data Libaray Functions (DILFD)
+14 ; #2056 - Data Base Server API: Data Retriever Utilities (DIQ)
+15 ; #10154 - DESCRIPTOR BLOCK - ^DD
+16 ;
+17 QUIT
+18 ;
FIND1C(SCDATA,SC) ; DDR FIND1 rpc callback
+1 NEW SCFILE,SCIENS,SCFLAGS,SCVAL,SCXREF,SCSCRN,SCERR,A,IEN,N,DIERR
+2 DO PARSE(.SC)
SET SCVAL=$GET(SC("VALUE"))
+3 SET A=$$FIND1^DIC(SCFILE,SCIENS,SCFLAGS,SCVAL,SCXREF,SCSCRN,"SCERR")
+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(SCOPT)["R"
SET IEN=$SELECT($GET(SCIENS)]"":A_SCIENS,1:A_",")
DO RECALL^DILFD(SCFILE,IEN,DUZ)
+8 QUIT
+9 ;
GETSC(SCDATA,SC) ; DDR GETS ENTRY DATA rpc callback
+1 NEW SCFILE,SCIENS,SCFLDS,SCFLAGS,SCOPT,SCRSLT,SCERR
+2 NEW SCXREF,SCSCRN,N
+3 DO PARSE(.SC)
+4 DO GETS^DIQ(SCFILE,SCIENS,SCFLDS,SCFLAGS,"SCRSLT","SCERR")
+5 SET N=0
+6 IF '$DATA(SCOPT)
DO 1
DO 2
QUIT
+7 IF $GET(SCOPT)["U"
DO 11
DO 21
+8 IF $GET(SCOPT)["?"
DO HLP
+9 QUIT
+10 ;
1 ;
+1 IF $DATA(SCRSLT)
Begin DoDot:1
+2 NEW SCFIELD,X,J
+3 DO SET("[Data]")
+4 SET SCFIELD=0
FOR
SET SCFIELD=$ORDER(SCRSLT(SCFILE,SCIENS,SCFIELD))
if 'SCFIELD
QUIT
Begin DoDot:2
+5 ;Do not remove stripping of ',' from IENS in line below if this code should work with T11 (21.1T1) of FM components.
+6 SET X=SCFILE_"^"_$EXTRACT(SCIENS,1,$LENGTH(SCIENS)-1)_"^"_SCFIELD_"^"
+7 IF $PIECE($GET(^DD(+$PIECE($GET(^DD(SCFILE,SCFIELD,0)),U,2),.01,0)),U,2)["W"
Begin DoDot:3
+8 DO SET(X_"[WORD PROCESSING]")
+9 SET J=0
FOR
SET J=$ORDER(SCRSLT(SCFILE,SCIENS,SCFIELD,J))
if 'J
QUIT
Begin DoDot:4
+10 DO SET(SCRSLT(SCFILE,SCIENS,SCFIELD,J))
End DoDot:4
+11 DO SET("$$END$$")
End DoDot:3
+12 IF '$TEST
Begin DoDot:3
+13 DO SET(X_$GET(SCRSLT(SCFILE,SCIENS,SCFIELD,"I"))_"^"_$GET(SCRSLT(SCFILE,SCIENS,SCFIELD,"E")))
End DoDot:3
End DoDot:2
End DoDot:1
+14 QUIT
+15 ;
11 ;
+1 NEW HD,I,E,B,J,K
+2 DO SET("[BEGIN_diDATA]")
+3 SET HD=SCFILE_U_$EXTRACT(SCIENS,1,$LENGTH(SCIENS)-1)
+4 SET I=SCFLAGS["I"
SET E=SCFLAGS["E"
SET B=(I&E)
+5 SET SCFIELD=0
FOR
SET SCFIELD=$ORDER(SCRSLT(SCFILE,SCIENS,SCFIELD))
if 'SCFIELD
QUIT
Begin DoDot:1
+6 IF $PIECE($GET(^DD(+$PIECE($GET(^DD(SCFILE,SCFIELD,0)),U,2),.01,0)),U,2)["W"
Begin DoDot:2
+7 SET (K,J)=0
FOR
SET K=$ORDER(SCRSLT(SCFILE,SCIENS,SCFIELD,K))
if 'K
QUIT
SET J=J+1
+8 DO SET(HD_U_SCFIELD_U_"W"_U_J)
+9 SET J=0
FOR
SET J=$ORDER(SCRSLT(SCFILE,SCIENS,SCFIELD,J))
if 'J
QUIT
DO SET(SCRSLT(SCFILE,SCIENS,SCFIELD,J))
+10 QUIT
End DoDot:2
QUIT
+11 SET FLG=$SELECT(B:"B",I:"I",1:"E")
+12 DO SET(HD_U_SCFIELD_U_FLG)
+13 IF B
DO SET(SCRSLT(SCFILE,SCIENS,SCFIELD,"E"))
DO SET(SCRSLT(SCFILE,SCIENS,SCFIELD,"I"))
QUIT
+14 IF E
DO SET(SCRSLT(SCFILE,SCIENS,SCFIELD,"E"))
QUIT
+15 IF I
DO SET(SCRSLT(SCFILE,SCIENS,SCFIELD,"I"))
QUIT
End DoDot:1
+16 DO SET("[END_diDATA]")
+17 QUIT
+18 ;
2 ;
+1 IF $DATA(SCERR)
DO SET("[ERROR]")
+2 QUIT
+3 ;
21 ;
+1 IF $DATA(DIERR)
DO ERROR
+2 QUIT
+3 ;
SET(X) ;
+1 SET N=N+1
+2 SET SCDATA(N)=X
+3 QUIT
+4 ;
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(SCFLDS,";",Z)
if 'FLD
QUIT
DO HELP(SCFILE,SCIENS,FLD,FLG)
+5 DO SET("[END_diHELP]")
+6 QUIT
+7 ;
GETHLPC(SCDATA,SC) ; SC GET DD HELP rpc callback
+1 NEW SCFILE,SCFIELD,SCFLGS,N
+2 SET SCFILE=$GET(SC("FILE"))
+3 SET SCFIELD=$GET(SC("FIELD"))
+4 SET SCFLGS=$GET(SC("FLAGS"))
+5 SET N=0
+6 DO SET("[BEGIN_diHELP]")
+7 DO HELP(SCFILE,"",SCFIELD,SCFLGS)
+8 DO SET("[END_diHELP]")
+9 QUIT
+10 ;
HELP(FILE,IENS,FIELD,FLGS) ;
+1 NEW SCHLP,HD,A
+2 DO HELP^DIE(FILE,IENS,FIELD,FLGS,"SCHLP")
+3 if '$DATA(SCHLP("DIHELP"))
QUIT
+4 SET HD=FILE_U_FIELD_U_"?"_U_SCHLP("DIHELP")
DO SET(HD)
+5 SET A=0
FOR
SET A=$ORDER(SCHLP("DIHELP",A))
if 'A
QUIT
DO SET(SCHLP("DIHELP",A))
+6 QUIT
+7 ;
ERROR ;
+1 DO SET("[BEGIN_diERRORS]")
+2 NEW A
SET A=0
FOR
SET A=$ORDER(SCERR("DIERR",A))
if 'A
QUIT
Begin DoDot:1
+3 NEW HD,PARAM,B,C,TEXT,TXTCNT,D,FILE,FIELD,IENS,%
+4 SET HD=SCERR("DIERR",A)
+5 IF $DATA(SCERR("DIERR",A,"PARAM",0))
Begin DoDot:2
+6 SET (B,D)=0
FOR C=1:1
SET B=$ORDER(SCERR("DIERR",A,"PARAM",B))
if B=""
QUIT
Begin DoDot:3
+7 IF B="FILE"
SET FILE=SCERR("DIERR",A,"PARAM","FILE")
+8 IF B="FIELD"
SET FIELD=SCERR("DIERR",A,"PARAM","FIELD")
+9 IF B="IENS"
SET IENS=SCERR("DIERR",A,"PARAM","IENS")
+10 SET D=D+1
SET PARAM(D)=B_U_SCERR("DIERR",A,"PARAM",B)
End DoDot:3
End DoDot:2
+11 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
+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 ;
PARSE(SC) ;
+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 SCXREF=$GET(SC("XREF"))
+6 SET SCSCRN=$GET(SC("SCREEN"))
+7 if $DATA(SC("OPTIONS"))
SET SCOPT=SC("OPTIONS")
+8 QUIT
+9 ;
