BGUFLR ; IHS/OIT/MJL - BGU FILER ;
;;1.5;BGU;;MAY 26, 2005
;
EN(BGUARRAY,BGUFILE,BGUDATA,BGUACTN,BGUFLAGS) ;PEP FROM REMOTE PROCEDURE BGU FILER
CTL ;
I $G(BGUFILE)'="",$G(BGUACTN)'="" D
.S D0=-1,BGUFILE=$$GETFID(BGUFILE),BGUDATA=$G(BGUDATA),BGUFLAGS=$G(BGUFLAGS)
.D INIT
.I BGUACTN="C" D CREATE Q
.I BGUACTN="M" D MODIFY Q
.I BGUACTN="D" D DELETE Q
D
.I $D(BGUEMSG) D ERROR Q
.S BGUARRAY(1)=1,BGUARRAY(2)="OK"
.Q:BGUACTN="D"
.F BGUN=1:1:$L(BGURIENS,$C(175)) S BGUX=$P(BGURIENS,$C(175),BGUN),BGUX=$E(BGUX,1,$L(BGUX)-1) D
..S BGUNP=$L(BGUX,","),BGUNPP=BGUNP+1,BGUY="",$P(BGUY,BGUNP,",")="" F BGUN1=1:1:BGUNP S BGUIEN=$P(BGUX,",",BGUN1),$P(BGUY,",",BGUNPP-BGUN1)=$S(BGUIEN=+BGUIEN:BGUIEN,1:$G(BGUENTS($P(BGUIEN,"+",2))))
..S $P(BGURIENS,$C(175),BGUN)=BGUY
.S BGUARRAY(2)=BGURIENS
D KILL
Q
;
INIT ;
S BGUS1=$C(25),BGUS2="~",BGUIENC=1,BGUIENC(1)=1
Q
;
CREATE ;
D BLDFDA,FILE
Q
;
MODIFY ;
S BGUENTS=""
D BLDFDA,FILE
Q
;
DELETE ;
S BGUFIELD=$P(BGUDATA,BGUS1,1),BGUIENS=$P(BGUDATA,BGUS1,2),DIK=$$GETGBL(BGUFILE),BGULEV=$L(BGUFIELD,"!"),BGUFILE1=BGUFILE
I BGUIENS="" S BGUEMSG="",BGUARRAY(1000)="NO ENTRY SELECTED TO DELETE" Q
S BGUN=0 F BGULEV1=1:1:BGULEV S BGUIEN=$P(BGUIENS,",",BGULEV1) Q:BGUIEN="" S DA=BGUIEN I BGULEV1<BGULEV S DA(BGULEV1)=DA,DIK=DIK_DA_","_$$GETNODE(BGUFILE1,$P(BGUFIELD,"!",BGULEV1))_","
I BGUIEN'="" D ^DIK Q
S DA=0 F S DA=$O(@(DIK_DA_")")) Q:'DA D ^DIK
Q
;
; Builds the FDA (FileMan Data Array)
BLDFDA ;
; Build array BLDORD sorted in FileMan field order
F BGUN=1:1:$L(BGUDATA,$C(175)) S BGUX=$P(BGUDATA,$C(175),BGUN),BGUFIELD=$P(BGUX,$C(20),1),BGUIENS=$P(BGUFIELD,BGUS1,2),BGUFIELD=$P(BGUFIELD,BGUS1,1) S:BGUIENS="" BGUIENS=0 D
.I D0=-1,BGUIENS S D0=$P(BGUIENS,",",1)
.S BGUSTR="" F BGUN1=1:1:$L(BGUFIELD,"!") S BGUSUB(BGUN1)=$P(BGUFIELD,"!",BGUN1) S:BGUN1>1 BGUSTR=BGUSTR_"," S BGUSTR=BGUSTR_"BGUSUB("_BGUN1_")"
.;S @("BGUORD("_BGUSTR_","""_BGUIENS_""","_BGUN_")")=BGUX
.S @("BGUORD("""_BGUIENS_""","_BGUSTR_","_BGUN_")")=BGUX
S BGUFIELD=""
S BGUXX="BGUORD",BGURIENS="",$P(BGURIENS,$C(175),$L(BGUDATA,$C(175)))="" F S BGUXX=$Q(@BGUXX) Q:BGUXX="" S BGUX=@BGUXX D
.S BGUFSEG=$P(BGUX,$C(20),1),BGUDAT=$P(BGUX,$C(20),2),BGULFLDS=BGUFIELD,BGUFIELD=$P(BGUFSEG,BGUS1,1),BGUIENS=$P(BGUFSEG,BGUS1,2) D SETIEN S $P(BGURIENS,$C(175),$P($P(BGUXX,",",$L(BGUXX,",")),")"))=BGUIENST
.I 'BGUWP S BGUFDA($$GETFILE(BGUFIELD),BGUIENST,BGULFLD)=BGUDAT Q
.;MJL 12/26/01 - WORD PROCESSING FIELDS WEREN'T WORKING
.I $P(BGUIENS,",",BGULEV+1)=""!(BGUDAT[$C(30)) S BGUFID=$$GETFILE($P(BGUFIELD,"!",1,BGULEV)),BGULFLD=$P(BGUFIELD,"!",BGULEV) D Q
..F BGUN1=1:1:$L(BGUDAT,$C(30)) S BGUWPD(BGUFID,BGUIENST,+BGULFLD,BGUN1)=$P(BGUDAT,$C(30),BGUN1)
.S BGUFID=$$GETFILE($P(BGUFIELD,"!",1,BGULEV)),BGULFLD=$P(BGUFIELD,"!",BGULEV),BGUWPD(BGUFID,BGUIENST,+BGULFLD,$P(BGUIENS,",",BGULEV+1))=BGUDAT
Q
;
; Builds the IEN string for the FDA array
SETIEN ;
I BGUACTN="C",BGUIENS,$E(BGUIENS)'="+" S BGUENTS(1)=+BGUIENS,$E(BGUIENS,1,$L(+BGUIENS))="+1"
S:$E(BGUIENS)="" BGUIENS="+1"
S BGUIENST="",BGULEV=$L(BGUFIELD,"!"),BGULFLD=$P(BGUFIELD,"!",BGULEV),BGUWP=$E(BGULFLD,$L(BGULFLD))="W",BGULEV=BGULEV-BGUWP
F BGUN1=1:1:BGULEV S BGUIEN=$P(BGUIENS,",",BGUN1),BGUFLD=$P(BGUFIELD,"!",BGUN1),BGUIENSV=$P(BGUIEN,":",2) S:BGUIENSV'="" BGUIEN=$P(BGUIEN,":",1),BGUENTS(+BGUIEN)=BGUIENSV S BGUIENST=BGUIEN_","_BGUIENST
Q
;
; Makes the update to FileMan
FILE ;
;
D UPDATE^DIE(BGUFLAGS,"BGUFDA","BGUENTS","BGUEMSG")
Q:'$D(BGUWPD)!($D(BGUEMSG))
K BGUFDA,BGUIENS
S BGUFID="" F S BGUFID=$O(BGUWPD(BGUFID)) Q:BGUFID="" S BGUIENS="" F S BGUIENS=$O(BGUWPD(BGUFID,BGUIENS)) Q:BGUIENS="" D
.S BGUWIENS="" F BGUN=1:1:$L(BGUIENS,",")-1 S BGUIEN=$P(BGUIENS,",",BGUN),BGUWIENS=BGUWIENS_$S(BGUIEN["+":$G(BGUENTS($P(BGUIEN,"+",2)),1),1:BGUIEN)_","
.S BGUFN="" F S BGUFN=$O(BGUWPD(BGUFID,BGUIENS,BGUFN)) Q:BGUFN="" Q:$D(BGUEMSG) D WP^DIE(BGUFID,BGUWIENS,BGUFN,"","BGUWPD("_BGUFID_","""_BGUIENS_""","_BGUFN_")","BGUEMSG")
K BGUWIENS,BGUWPD
Q
;
; Input: FileMan name Returns: FileMan file number
GETFID(BGUX) ;INTERNAL EP
S:'BGUX BGUX=$O(^DIC("B",BGUX,"")) Q:BGUX="" ""
I '$D(^DIC(BGUX)) Q ""
Q BGUX
;
GETFILE(BGUX) ;
Q:BGUX=+BGUX BGUFILE
S BGUFILE1=BGUFILE
F BGUNN=1:1:$L(BGUX,"!")-1 S BGUX1=$P(BGUX,"!",BGUNN),BGUFILE1=+$P(^DD(BGUFILE1,BGUX1,0),U,2) Q:'BGUFILE1
Q:'BGUFILE1 BGUFILE
Q BGUFILE1
;
GETGBL(BGUX) ;
S:'BGUX BGUX=$O(^DIC("B",BGUX,"")) Q:BGUX="" BGUX
S BGUX=$G(^DIC(BGUX,0,"GL"))
Q BGUX
;
GETNODE(BGUX,BGUX1) ;
S BGUFILE1=^DD(BGUFILE1,BGUX1,0),BGUX1=$P($P(BGUFILE1,U,4),";"),BGUFILE1=+$P(BGUFILE1,U,2)
S:BGUX1?.E1A.E BGUX1=""""_BGUX1_""""
Q BGUX1
;
; Send copy of error text returned from ^DIE to RPC broker.
ERROR ;
S BGUARRAY(1)=-1
S BGUN=1,BGUN1="" F S BGUN1=$O(BGUEMSG("DIERR",BGUN1)) Q:'BGUN1 S BGUN2="" F S BGUN2=$O(BGUEMSG("DIERR",BGUN1,"TEXT",BGUN2)) Q:'BGUN2 S BGUN=BGUN+1,BGUARRAY(BGUN)=BGUEMSG("DIERR",BGUN1,"TEXT",BGUN2)
K BGUEMSG
Q
;
KILL ;
K BGUDAT,BGUDATA,BGUENTS,BGUFDA,BGUFID,BGUFIELD,BGUFILE,BGUFILE1,BGUFLAGS,BGUFLD,BGUFN,BGUFSEG,BGUIEN,BGUIENSV,BGUIENC,BGUIENS,BGUIENST,BGULEV,BGULEV1,BGULFLD,BGULFLDS,BGUN,BGUN1,BGUN2,BGUNN,BGUNP,BGUNPP,BGUORD,BGURIENS
K BGUS1,BGUS2,BGUSTR,BGUSUB,BGUWIENS,BGUWP,BGUWPD,BGUX,BGUX1,BGUXX,BGUY,DA,DIK
Q
BGUFLR ; IHS/OIT/MJL - BGU FILER ;
+1 ;;1.5;BGU;;MAY 26, 2005
+2 ;
EN(BGUARRAY,BGUFILE,BGUDATA,BGUACTN,BGUFLAGS) ;PEP FROM REMOTE PROCEDURE BGU FILER
CTL ;
+1 IF $GET(BGUFILE)'=""
IF $GET(BGUACTN)'=""
Begin DoDot:1
+2 SET D0=-1
SET BGUFILE=$$GETFID(BGUFILE)
SET BGUDATA=$GET(BGUDATA)
SET BGUFLAGS=$GET(BGUFLAGS)
+3 DO INIT
+4 IF BGUACTN="C"
DO CREATE
QUIT
+5 IF BGUACTN="M"
DO MODIFY
QUIT
+6 IF BGUACTN="D"
DO DELETE
QUIT
End DoDot:1
+7 Begin DoDot:1
+8 IF $DATA(BGUEMSG)
DO ERROR
QUIT
+9 SET BGUARRAY(1)=1
SET BGUARRAY(2)="OK"
+10 IF BGUACTN="D"
QUIT
+11 FOR BGUN=1:1:$LENGTH(BGURIENS,$CHAR(175))
SET BGUX=$PIECE(BGURIENS,$CHAR(175),BGUN)
SET BGUX=$EXTRACT(BGUX,1,$LENGTH(BGUX)-1)
Begin DoDot:2
+12 SET BGUNP=$LENGTH(BGUX,",")
SET BGUNPP=BGUNP+1
SET BGUY=""
SET $PIECE(BGUY,BGUNP,",")=""
FOR BGUN1=1:1:BGUNP
SET BGUIEN=$PIECE(BGUX,",",BGUN1)
SET $PIECE(BGUY,",",BGUNPP-BGUN1)=$SELECT(BGUIEN=+BGUIEN:BGUIEN,1:$GET(BGUENTS($PIECE(BGUIEN,"+",2))))
+13 SET $PIECE(BGURIENS,$CHAR(175),BGUN)=BGUY
End DoDot:2
+14 SET BGUARRAY(2)=BGURIENS
End DoDot:1
+15 DO KILL
+16 QUIT
+17 ;
INIT ;
+1 SET BGUS1=$CHAR(25)
SET BGUS2="~"
SET BGUIENC=1
SET BGUIENC(1)=1
+2 QUIT
+3 ;
CREATE ;
+1 DO BLDFDA
DO FILE
+2 QUIT
+3 ;
MODIFY ;
+1 SET BGUENTS=""
+2 DO BLDFDA
DO FILE
+3 QUIT
+4 ;
DELETE ;
+1 SET BGUFIELD=$PIECE(BGUDATA,BGUS1,1)
SET BGUIENS=$PIECE(BGUDATA,BGUS1,2)
SET DIK=$$GETGBL(BGUFILE)
SET BGULEV=$LENGTH(BGUFIELD,"!")
SET BGUFILE1=BGUFILE
+2 IF BGUIENS=""
SET BGUEMSG=""
SET BGUARRAY(1000)="NO ENTRY SELECTED TO DELETE"
QUIT
+3 SET BGUN=0
FOR BGULEV1=1:1:BGULEV
SET BGUIEN=$PIECE(BGUIENS,",",BGULEV1)
IF BGUIEN=""
QUIT
SET DA=BGUIEN
IF BGULEV1<BGULEV
SET DA(BGULEV1)=DA
SET DIK=DIK_DA_","_$$GETNODE(BGUFILE1,$PIECE(BGUFIELD,"!",BGULEV1))_","
+4 IF BGUIEN'=""
DO ^DIK
QUIT
+5 SET DA=0
FOR
SET DA=$ORDER(@(DIK_DA_")"))
IF 'DA
QUIT
DO ^DIK
+6 QUIT
+7 ;
+8 ; Builds the FDA (FileMan Data Array)
BLDFDA ;
+1 ; Build array BLDORD sorted in FileMan field order
+2 FOR BGUN=1:1:$LENGTH(BGUDATA,$CHAR(175))
SET BGUX=$PIECE(BGUDATA,$CHAR(175),BGUN)
SET BGUFIELD=$PIECE(BGUX,$CHAR(20),1)
SET BGUIENS=$PIECE(BGUFIELD,BGUS1,2)
SET BGUFIELD=$PIECE(BGUFIELD,BGUS1,1)
IF BGUIENS=""
SET BGUIENS=0
Begin DoDot:1
+3 IF D0=-1
IF BGUIENS
SET D0=$PIECE(BGUIENS,",",1)
+4 SET BGUSTR=""
FOR BGUN1=1:1:$LENGTH(BGUFIELD,"!")
SET BGUSUB(BGUN1)=$PIECE(BGUFIELD,"!",BGUN1)
IF BGUN1>1
SET BGUSTR=BGUSTR_","
SET BGUSTR=BGUSTR_"BGUSUB("_BGUN1_")"
+5 ;S @("BGUORD("_BGUSTR_","""_BGUIENS_""","_BGUN_")")=BGUX
+6 SET @("BGUORD("""_BGUIENS_""","_BGUSTR_","_BGUN_")")=BGUX
End DoDot:1
+7 SET BGUFIELD=""
+8 SET BGUXX="BGUORD"
SET BGURIENS=""
SET $PIECE(BGURIENS,$CHAR(175),$LENGTH(BGUDATA,$CHAR(175)))=""
FOR
SET BGUXX=$QUERY(@BGUXX)
IF BGUXX=""
QUIT
SET BGUX=@BGUXX
Begin DoDot:1
+9 SET BGUFSEG=$PIECE(BGUX,$CHAR(20),1)
SET BGUDAT=$PIECE(BGUX,$CHAR(20),2)
SET BGULFLDS=BGUFIELD
SET BGUFIELD=$PIECE(BGUFSEG,BGUS1,1)
SET BGUIENS=$PIECE(BGUFSEG,BGUS1,2)
DO SETIEN
SET $PIECE(BGURIENS,$CHAR(175),$PIECE($PIECE(BGUXX,",",$LENGTH(BGUXX,",")),")"))=BGUIENST
+10 IF 'BGUWP
SET BGUFDA($$GETFILE(BGUFIELD),BGUIENST,BGULFLD)=BGUDAT
QUIT
+11 ;MJL 12/26/01 - WORD PROCESSING FIELDS WEREN'T WORKING
+12 IF $PIECE(BGUIENS,",",BGULEV+1)=""!(BGUDAT[$CHAR(30))
SET BGUFID=$$GETFILE($PIECE(BGUFIELD,"!",1,BGULEV))
SET BGULFLD=$PIECE(BGUFIELD,"!",BGULEV)
Begin DoDot:2
+13 FOR BGUN1=1:1:$LENGTH(BGUDAT,$CHAR(30))
SET BGUWPD(BGUFID,BGUIENST,+BGULFLD,BGUN1)=$PIECE(BGUDAT,$CHAR(30),BGUN1)
End DoDot:2
QUIT
+14 SET BGUFID=$$GETFILE($PIECE(BGUFIELD,"!",1,BGULEV))
SET BGULFLD=$PIECE(BGUFIELD,"!",BGULEV)
SET BGUWPD(BGUFID,BGUIENST,+BGULFLD,$PIECE(BGUIENS,",",BGULEV+1))=BGUDAT
End DoDot:1
+15 QUIT
+16 ;
+17 ; Builds the IEN string for the FDA array
SETIEN ;
+1 IF BGUACTN="C"
IF BGUIENS
IF $EXTRACT(BGUIENS)'="+"
SET BGUENTS(1)=+BGUIENS
SET $EXTRACT(BGUIENS,1,$LENGTH(+BGUIENS))="+1"
+2 IF $EXTRACT(BGUIENS)=""
SET BGUIENS="+1"
+3 SET BGUIENST=""
SET BGULEV=$LENGTH(BGUFIELD,"!")
SET BGULFLD=$PIECE(BGUFIELD,"!",BGULEV)
SET BGUWP=$EXTRACT(BGULFLD,$LENGTH(BGULFLD))="W"
SET BGULEV=BGULEV-BGUWP
+4 FOR BGUN1=1:1:BGULEV
SET BGUIEN=$PIECE(BGUIENS,",",BGUN1)
SET BGUFLD=$PIECE(BGUFIELD,"!",BGUN1)
SET BGUIENSV=$PIECE(BGUIEN,":",2)
IF BGUIENSV'=""
SET BGUIEN=$PIECE(BGUIEN,":",1)
SET BGUENTS(+BGUIEN)=BGUIENSV
SET BGUIENST=BGUIEN_","_BGUIENST
+5 QUIT
+6 ;
+7 ; Makes the update to FileMan
FILE ;
+1 ;
+2 DO UPDATE^DIE(BGUFLAGS,"BGUFDA","BGUENTS","BGUEMSG")
+3 IF '$DATA(BGUWPD)!($DATA(BGUEMSG))
QUIT
+4 KILL BGUFDA,BGUIENS
+5 SET BGUFID=""
FOR
SET BGUFID=$ORDER(BGUWPD(BGUFID))
IF BGUFID=""
QUIT
SET BGUIENS=""
FOR
SET BGUIENS=$ORDER(BGUWPD(BGUFID,BGUIENS))
IF BGUIENS=""
QUIT
Begin DoDot:1
+6 SET BGUWIENS=""
FOR BGUN=1:1:$LENGTH(BGUIENS,",")-1
SET BGUIEN=$PIECE(BGUIENS,",",BGUN)
SET BGUWIENS=BGUWIENS_$SELECT(BGUIEN["+":$GET(BGUENTS($PIECE(BGUIEN,"+",2)),1),1:BGUIEN)_","
+7 SET BGUFN=""
FOR
SET BGUFN=$ORDER(BGUWPD(BGUFID,BGUIENS,BGUFN))
IF BGUFN=""
QUIT
IF $DATA(BGUEMSG)
QUIT
DO WP^DIE(BGUFID,BGUWIENS,BGUFN,"","BGUWPD("_BGUFID_","""_BGUIENS_""","_BGUFN_")","BGUEMSG")
End DoDot:1
+8 KILL BGUWIENS,BGUWPD
+9 QUIT
+10 ;
+11 ; Input: FileMan name Returns: FileMan file number
GETFID(BGUX) ;INTERNAL EP
+1 IF 'BGUX
SET BGUX=$ORDER(^DIC("B",BGUX,""))
IF BGUX=""
QUIT ""
+2 IF '$DATA(^DIC(BGUX))
QUIT ""
+3 QUIT BGUX
+4 ;
GETFILE(BGUX) ;
+1 IF BGUX=+BGUX
QUIT BGUFILE
+2 SET BGUFILE1=BGUFILE
+3 FOR BGUNN=1:1:$LENGTH(BGUX,"!")-1
SET BGUX1=$PIECE(BGUX,"!",BGUNN)
SET BGUFILE1=+$PIECE(^DD(BGUFILE1,BGUX1,0),U,2)
IF 'BGUFILE1
QUIT
+4 IF 'BGUFILE1
QUIT BGUFILE
+5 QUIT BGUFILE1
+6 ;
GETGBL(BGUX) ;
+1 IF 'BGUX
SET BGUX=$ORDER(^DIC("B",BGUX,""))
IF BGUX=""
QUIT BGUX
+2 SET BGUX=$GET(^DIC(BGUX,0,"GL"))
+3 QUIT BGUX
+4 ;
GETNODE(BGUX,BGUX1) ;
+1 SET BGUFILE1=^DD(BGUFILE1,BGUX1,0)
SET BGUX1=$PIECE($PIECE(BGUFILE1,U,4),";")
SET BGUFILE1=+$PIECE(BGUFILE1,U,2)
+2 IF BGUX1?.E1A.E
SET BGUX1=""""_BGUX1_""""
+3 QUIT BGUX1
+4 ;
+5 ; Send copy of error text returned from ^DIE to RPC broker.
ERROR ;
+1 SET BGUARRAY(1)=-1
+2 SET BGUN=1
SET BGUN1=""
FOR
SET BGUN1=$ORDER(BGUEMSG("DIERR",BGUN1))
IF 'BGUN1
QUIT
SET BGUN2=""
FOR
SET BGUN2=$ORDER(BGUEMSG("DIERR",BGUN1,"TEXT",BGUN2))
IF 'BGUN2
QUIT
SET BGUN=BGUN+1
SET BGUARRAY(BGUN)=BGUEMSG("DIERR",BGUN1,"TEXT",BGUN2)
+3 KILL BGUEMSG
+4 QUIT
+5 ;
KILL ;
+1 KILL BGUDAT,BGUDATA,BGUENTS,BGUFDA,BGUFID,BGUFIELD,BGUFILE,BGUFILE1,BGUFLAGS,BGUFLD,BGUFN,BGUFSEG,BGUIEN,BGUIENSV,BGUIENC,BGUIENS,BGUIENST,BGULEV,BGULEV1,BGULFLD,BGULFLDS,BGUN,BGUN1,BGUN2,BGUNN,BGUNP,BGUNPP,BGUORD,BGURIENS
+2 KILL BGUS1,BGUS2,BGUSTR,BGUSUB,BGUWIENS,BGUWP,BGUWPD,BGUX,BGUX1,BGUXX,BGUY,DA,DIK
+3 QUIT
