BMXRPC9 ; IHS/OIT/HMW - RPC CALL FOR EXTENDED BROKER FUNCTIONALITY ;
;;4.0;BMX;;JUN 28, 2010
; UPDATE FILEMAN WITH AN ADO RECORD SET FROM A WINDOWS APPLICATION
;
;
;
SONLY(BMXY,BMXVAL) ;EP Schema Only
;
I BMXVAL="TRUE" S BMX("SCHEMA ONLY")=1
E S BMX("SCHEMA ONLY")=0
S BMXY=BMX("SCHEMA ONLY")
;
Q
;
;
;
TESTADO(BMXOUT,HEADER,ROWDATA,ROWCOUNT,HANGSEC,ASYNCID) ;
; ROWDATA IS | DELIMITED, REPLACE WITH ^ AND END> BMXIEN DONE FOR YOU
N BMXTMP,HANGTIME,BMXI,BMXGBL,INC
S U="^"
I $L($G(ASYNCID)) S BMXGBL=$NA(^BMXTMP("TESTADO",$G(ASYNCID),$J))
E S BMXGBL=$NA(^BMXTMP("TESTADO",$J))
K @BMXGBL
S BMXI=0
S @BMXGBL@(BMXI)=$TR("I00010BMXIEN|"_HEADER,"|",U)_$C(30)
S ROWDATA=$TR(ROWDATA,"|",U)_$C(30)
F I=1:1:+$G(ROWCOUNT) D
. S BMXI=BMXI+1
. S @BMXGBL@(BMXI)=I_U_ROWDATA
. Q
S BMXI=BMXI+1
S @BMXGBL@(BMXI)=$C(31)
H +$G(HANGSEC)
S BMXOUT=BMXGBL
Q
;
TESTECHO(BMXOUT,ECHO,REPEAT,HANGSEC) ;
I $L($G(REPEAT))=0 S REPEAT=1
S REPEAT=+$G(REPEAT)-1
S BMXOUT=ECHO
F I=1:1:REPEAT D
. S BMXOUT=BMXOUT_"~"_ECHO
. Q
H +$G(HANGSEC)
Q
;
TESTRPC(BMXGBL,BMXSQL) ;
;Test retrieval/update statement
;
N BMXI,BMXERR,BMXN,BMXNOD,BMXNAM,BMXSEX,BMXDOB,BMXFAC,BMXTMP,BMXJ
S X="ETRAP^BMXRPC9",@^%ZOSF("TRAP")
S BMXGBL="^BMXTMP("_$J_")",BMXERR="",U="^"
K ^BMXTMP($J)
S BMXI=0
;
;Old column info format:
;S BMXI=BMXI+1,^BMXTMP($J,BMXI)="I00010BMXIEN"_U_"D00010DOB"_U_"T00030LOCAL_FACLILITY"_U_"T00030NAME"_U_"T00010SEX"_$C(30)
;
;New column info format is @@@meta@@@KEYFIELD|FILE#
; For each field: ^FILE#|FIELD#|DATATYPE|LENGTH|FIELDNAME|READONLY|KEYFIELD|NULL ALLOWED
;S BMXI=BMXI+1,^BMXTMP($J,BMXI)="@@@meta@@@"
;S BMXI=BMXI+1,^BMXTMP($J,BMXI)="BMXIEN|2160010^"
;S BMXI=BMXI+1,^BMXTMP($J,BMXI)="2160010|.001|I|10|BMXIEN|TRUE|TRUE^"
;S BMXI=BMXI+1,^BMXTMP($J,BMXI)="2160010|.03|D|10|DOB|FALSE|FALSE^"
;S BMXI=BMXI+1,^BMXTMP($J,BMXI)="2160010|.04|T|60|LOCAL_FACILITY|FALSE|FALSE^"
;S BMXI=BMXI+1,^BMXTMP($J,BMXI)="2160010|.01|T|30|NAME|FALSE|FALSE^"
;S BMXI=BMXI+1,^BMXTMP($J,BMXI)="2160010|.02|T|10|SEX|FALSE|FALSE"
;S BMXI=BMXI+1,^BMXTMP($J,BMXI)=$C(30)
;
D SS^BMXADO(.BMXTMP,"","TEST1")
I $G(BMXTMP)=$C(30) D ERR(99,"SCHEMA GENERATION FAILED") Q
S BMXJ=0 F S BMXJ=$O(BMXTMP(BMXJ)) Q:'+BMXJ D
. S BMXI=BMXI+1
. S ^BMXTMP($J,BMXI)=BMXTMP(BMXJ)
I +$G(BMX("SCHEMA ONLY")) D Q
. S BMXI=BMXI+1
. S ^BMXTMP($J,BMXI)=$C(31)
. Q
S BMXN=0
F S BMXN=$O(^DIZ(2160010,BMXN)) Q:'+BMXN D
. Q:'$D(^DIZ(2160010,BMXN,0))
. S BMXNOD=^DIZ(2160010,BMXN,0)
. S BMXNAM=$P(BMXNOD,U)
. S BMXSEX=$P(BMXNOD,U,2)
. S BMXDOB=$P(BMXNOD,U,3)
. S Y=BMXDOB X ^DD("DD") S BMXDOB=Y
. S BMXFAC=$P(BMXNOD,U,4)
. S:+BMXFAC BMXFAC=$P($G(^DIC(4,BMXFAC,0)),U)
. S BMXI=BMXI+1
. S ^BMXTMP($J,BMXI)=BMXN_U_BMXDOB_U_BMXFAC_U_BMXNAM_U_BMXSEX_$C(30)
. Q
S BMXI=BMXI+1
S ^BMXTMP($J,BMXI)=$C(31)
Q
;
ERR(BMXID,BMXERR) ;Error processing
K ^BMXTMP($J)
S ^BMXTMP($J,0)="I00030ERRORID^T00030ERRORMSG"_$C(30)
S ^BMXTMP($J,1)=BMXID_"^"_BMXERR_$C(30)
S ^BMXTMP($J,2)=$C(31)
Q
;
ETRAP ;EP Error trap entry
D ^%ZTER
D ERR(99,"BMXRPC9 Error: "_$G(%ZTERROR))
Q
;
TEST N OUT S OUT="" D ADO(.OUT,2160010,"1",(".01|A,A"_$C(30)_".02|M"_$C(30)_".03|1/5/1946"_$C(30)_".04|SAN XAVIER"_$C(31))) W !,OUT
Q
;
ADOD(OUT,FILE,IEN,DATA) ;
;
;D DEBUG^%Serenji("ADOD^BMXRPC9(.OUT,FILE,IEN,DATA)")
;
Q
;
ADO(OUT,FILE,IEN,DATA) ; RPC CALL: OUT = OUTBOUND MESSAGE, FILE = FILEMAN FILE NUMBER, IEN = FILE INTERNAL ENTRY NUMBER, DATA = DATA STRING
N OREF,CREF,DIC,DIE,DA,DR,X,Y,%,FLD,CNT,FNO,VAL,TFLG,DFLG,TOT,UFLG,XTFLG,GTFLG,GDFLG
S OUT="",FLD="",GTFLG=0,GDFLG=0
S IEN=$G(IEN)
I $E(IEN)="-" S IEN=$E(IEN,2,99),GDFLG=1 ; GLOBAL DELETE FLAG
I $E(IEN)="+" S IEN=$E(IEN,2,99),GTFLG=1 ; GLOBAL TRANSACTION FLAG, ROLLBACK IF ANY FIELD FAILS TO UPDATE
I IEN="Add"!(IEN="ADD") S IEN=""
I '$D(^DIC(+$G(FILE),0,"GL")) S OUT="Update cancelled. Invalid FILE number" Q
S OREF=^DIC(FILE,0,"GL") I '$L(OREF) S OUT="Update cancelled. Invalid file definition" Q
S CREF=$E(OREF,1,$L(OREF)-1) I $E(OREF,$L(OREF))="," S CREF=CREF_")" ; CONVERT OREF TO CREF
I IEN,'$D(@CREF@(IEN)) S OUT="Update cancelled. Invalid IEN" Q
I 'GDFLG,IEN,(DATA["-.01|"!(DATA[".01|@")) S GDFLG=1
I GDFLG,'IEN S OUT="Deletion cancelled. Missing IEN" Q
I GDFLG D DIK(OREF,IEN) S OUT="Record deleted|"_IEN Q
S UFLG=$S($G(IEN):"E",1:"A") ; UPDATE FLAG: ADD OR EDIT
I '$L($G(DATA)) S OUT="Update cancelled. Missing/invalid data string" Q
S TOT=$L(DATA,$C(30)) I 'TOT S OUT="Update cancelled. Missing data string" Q
F CNT=1:1:TOT S DATA(CNT)=$P(DATA,$C(30),CNT) ; BUILD PRIMARY FIELD ARRAY
S %=DATA(1) I %=""!(%=$C(31)) S OUT="Update cancelled. Missing data string" Q
S %=DATA(CNT) I %[$C(31) S %=$P(%,$C(31),1),DATA(CNT)=% ; STRIP OFF END OF FILE MARKER
F CNT=1:1:TOT S X=DATA(CNT) I $L(X) D ; BUILD SECONDARY FIELD ARRAY
. S TFLG=0,DFLG=0
. I $E(X)="+" S TFLG=1,X=$E(X,2,999),$P(FLD,U)=1
. I $E(X)="-" S DFLG=1,X=$E(X,2,999)
. S FNO=$P(X,"|"),VAL=$P(X,"|",2)
. I '$D(^DD(FILE,+$G(FNO),0)) S:$L(OUT) OUT=OUT_"~" S OUT=OUT_FNO_"|Invalid field number" Q
. I DFLG,VAL'="" S:$L(OUT) OUT=OUT_"~" S OUT=OUT_FNO_"|Invalid deletion syntax" Q ; CANT DELETE IF A VALUE IS SENT
. I DFLG!(VAL="") S VAL="@" ; SYNC DFLG AND VAL
. I VAL="@" S DFLG=1 ; SYNC DFLG AND VAL
. S FLD(FNO)=VAL_U_TFLG_U_DFLG
. I FNO=.01,TFLG S $P(FLD,U,2)=1 ;
. Q
I $P($G(FLD(.01)),U,3),UFLG="A" S OUT="Record deletion cancelled. Missing IEN" Q ; CAN'T DELETE A RECORD WITHOUT A VALID IEN
DELREC I $P($G(FLD(.01)),U,3) D DIK(OREF,IEN) S OUT="OK" Q ; DELETE THE RECORD
I UFLG="A",'$L($P($G(FLD(.01)),U)) S OUT="Record addition cancelled. Missing .01 field" Q ; CAN'T ADD A RECORD WITHOUT A VALID .01 FIELD
ADDREC I UFLG="A" D ADD(OREF) Q ; ADD A NEW ENTRY TO A FILE
EDITREC I UFLG="E" D EDIT(OREF,IEN) Q ; EDIT AN EXISTING RECORD
Q
;
DIK(DIK,DA) ; DELETE A RECORD
D ^DIK
D ^XBFMK
Q
;
ADD(DIC) ; ADD A NEW ENTRY TO A FILE
N X,Y
S X=""""_$P($G(FLD(.01)),U)_""""
S DIC(0)="L"
D ^DIC
I Y=-1 S OUT="Unable to add a new record" G AX
I $O(FLD(.01)) D EDIT(DIC,+Y) Q
S OUT="OK"_"|"_+Y
AX D ^XBFMK
Q
;
EDIT(DIE,DA) ; EDIT AN EXISTING RECORD
N DR,RFLG,ERR,FNO,VAL,TFLG,RESULT,MSG,DIERR,DISYS
S FNO=$O(FLD(.01),-1),DR="" ;HMW Changed to include .01 in DR string
I UFLG="A" S OUT="New record added|"_DA
F S FNO=$O(FLD(FNO)) Q:'FNO S X=FLD(FNO) I $L(X) D I $G(RFLG) Q ; CHECK EA FIELD AND BUILD THE DR STRING AND ERROR STRING
. S VAL(FNO)=$P(X,U),TFLG=$P(X,U,2) I '$L(VAL(FNO)) Q
. K ERR,RESULT
. I VAL(FNO)="@"!(VAL(FNO)="") S RESULT="@"
. E D CHK^DIE(FILE,FNO,"",VAL(FNO),.RESULT,"ERR")
. I RESULT=U D Q
.. S MSG=$G(ERR("DIERR",1,"TEXT",1),"Failed FileMan data validation")
.. I $L(OUT) S OUT=OUT_"~"
.. I TFLG!GTFLG S RFLG=1,OUT=FNO_"|"_MSG Q
.. S OUT=OUT_FNO_"|"_MSG
.. Q
. S VAL(FNO)=RESULT
. I $L(DR) S DR=DR_";"
. S DR=DR_FNO_"////^S X=VAL("_FNO_")" ; BUILD DR STRING
. Q
I $G(RFLG) D:UFLG="A" DIK(DIE,DA) S OUT="Record update cancelled"_"|"_OUT G EX ; TRANSACTION ROLLBACK FLAG IS SET, ENTRY DELETED (ADD MODE) OR UPDATE CANCELLED (EDIT MODE)
L +@CREF@(DA):2 I $T D ^DIE L -@CREF@(DA) G:OUT["valid" EX S OUT="OK" S:UFLG="A" OUT=OUT_"|"_DA G EX ; SUCCESS!!!!
S OUT="Update cancelled. File locked" ; FILE LOCKED. UNABLE TO UPDATE
I $L(FLD),UFLG="A" D DIK(DIE,DA) ; ROLLBACK THE NEW RECORD
EX D ^XBFMK ; CLEANUP
Q
;
BMXRPC9 ; IHS/OIT/HMW - RPC CALL FOR EXTENDED BROKER FUNCTIONALITY ;
+1 ;;4.0;BMX;;JUN 28, 2010
+2 ; UPDATE FILEMAN WITH AN ADO RECORD SET FROM A WINDOWS APPLICATION
+3 ;
+4 ;
+5 ;
SONLY(BMXY,BMXVAL) ;EP Schema Only
+1 ;
+2 IF BMXVAL="TRUE"
SET BMX("SCHEMA ONLY")=1
+3 IF '$TEST
SET BMX("SCHEMA ONLY")=0
+4 SET BMXY=BMX("SCHEMA ONLY")
+5 ;
+6 QUIT
+7 ;
+8 ;
+9 ;
TESTADO(BMXOUT,HEADER,ROWDATA,ROWCOUNT,HANGSEC,ASYNCID) ;
+1 ; ROWDATA IS | DELIMITED, REPLACE WITH ^ AND END> BMXIEN DONE FOR YOU
+2 NEW BMXTMP,HANGTIME,BMXI,BMXGBL,INC
+3 SET U="^"
+4 IF $LENGTH($GET(ASYNCID))
SET BMXGBL=$NAME(^BMXTMP("TESTADO",$GET(ASYNCID),$JOB))
+5 IF '$TEST
SET BMXGBL=$NAME(^BMXTMP("TESTADO",$JOB))
+6 KILL @BMXGBL
+7 SET BMXI=0
+8 SET @BMXGBL@(BMXI)=$TRANSLATE("I00010BMXIEN|"_HEADER,"|",U)_$CHAR(30)
+9 SET ROWDATA=$TRANSLATE(ROWDATA,"|",U)_$CHAR(30)
+10 FOR I=1:1:+$GET(ROWCOUNT)
Begin DoDot:1
+11 SET BMXI=BMXI+1
+12 SET @BMXGBL@(BMXI)=I_U_ROWDATA
+13 QUIT
End DoDot:1
+14 SET BMXI=BMXI+1
+15 SET @BMXGBL@(BMXI)=$CHAR(31)
+16 HANG +$GET(HANGSEC)
+17 SET BMXOUT=BMXGBL
+18 QUIT
+19 ;
TESTECHO(BMXOUT,ECHO,REPEAT,HANGSEC) ;
+1 IF $LENGTH($GET(REPEAT))=0
SET REPEAT=1
+2 SET REPEAT=+$GET(REPEAT)-1
+3 SET BMXOUT=ECHO
+4 FOR I=1:1:REPEAT
Begin DoDot:1
+5 SET BMXOUT=BMXOUT_"~"_ECHO
+6 QUIT
End DoDot:1
+7 HANG +$GET(HANGSEC)
+8 QUIT
+9 ;
TESTRPC(BMXGBL,BMXSQL) ;
+1 ;Test retrieval/update statement
+2 ;
+3 NEW BMXI,BMXERR,BMXN,BMXNOD,BMXNAM,BMXSEX,BMXDOB,BMXFAC,BMXTMP,BMXJ
+4 SET X="ETRAP^BMXRPC9"
SET @^%ZOSF("TRAP")
+5 SET BMXGBL="^BMXTMP("_$JOB_")"
SET BMXERR=""
SET U="^"
+6 KILL ^BMXTMP($JOB)
+7 SET BMXI=0
+8 ;
+9 ;Old column info format:
+10 ;S BMXI=BMXI+1,^BMXTMP($J,BMXI)="I00010BMXIEN"_U_"D00010DOB"_U_"T00030LOCAL_FACLILITY"_U_"T00030NAME"_U_"T00010SEX"_$C(30)
+11 ;
+12 ;New column info format is @@@meta@@@KEYFIELD|FILE#
+13 ; For each field: ^FILE#|FIELD#|DATATYPE|LENGTH|FIELDNAME|READONLY|KEYFIELD|NULL ALLOWED
+14 ;S BMXI=BMXI+1,^BMXTMP($J,BMXI)="@@@meta@@@"
+15 ;S BMXI=BMXI+1,^BMXTMP($J,BMXI)="BMXIEN|2160010^"
+16 ;S BMXI=BMXI+1,^BMXTMP($J,BMXI)="2160010|.001|I|10|BMXIEN|TRUE|TRUE^"
+17 ;S BMXI=BMXI+1,^BMXTMP($J,BMXI)="2160010|.03|D|10|DOB|FALSE|FALSE^"
+18 ;S BMXI=BMXI+1,^BMXTMP($J,BMXI)="2160010|.04|T|60|LOCAL_FACILITY|FALSE|FALSE^"
+19 ;S BMXI=BMXI+1,^BMXTMP($J,BMXI)="2160010|.01|T|30|NAME|FALSE|FALSE^"
+20 ;S BMXI=BMXI+1,^BMXTMP($J,BMXI)="2160010|.02|T|10|SEX|FALSE|FALSE"
+21 ;S BMXI=BMXI+1,^BMXTMP($J,BMXI)=$C(30)
+22 ;
+23 DO SS^BMXADO(.BMXTMP,"","TEST1")
+24 IF $GET(BMXTMP)=$CHAR(30)
DO ERR(99,"SCHEMA GENERATION FAILED")
QUIT
+25 SET BMXJ=0
FOR
SET BMXJ=$ORDER(BMXTMP(BMXJ))
IF '+BMXJ
QUIT
Begin DoDot:1
+26 SET BMXI=BMXI+1
+27 SET ^BMXTMP($JOB,BMXI)=BMXTMP(BMXJ)
End DoDot:1
+28 IF +$GET(BMX("SCHEMA ONLY"))
Begin DoDot:1
+29 SET BMXI=BMXI+1
+30 SET ^BMXTMP($JOB,BMXI)=$CHAR(31)
+31 QUIT
End DoDot:1
QUIT
+32 SET BMXN=0
+33 FOR
SET BMXN=$ORDER(^DIZ(2160010,BMXN))
IF '+BMXN
QUIT
Begin DoDot:1
+34 IF '$DATA(^DIZ(2160010,BMXN,0))
QUIT
+35 SET BMXNOD=^DIZ(2160010,BMXN,0)
+36 SET BMXNAM=$PIECE(BMXNOD,U)
+37 SET BMXSEX=$PIECE(BMXNOD,U,2)
+38 SET BMXDOB=$PIECE(BMXNOD,U,3)
+39 SET Y=BMXDOB
XECUTE ^DD("DD")
SET BMXDOB=Y
+40 SET BMXFAC=$PIECE(BMXNOD,U,4)
+41 IF +BMXFAC
SET BMXFAC=$PIECE($GET(^DIC(4,BMXFAC,0)),U)
+42 SET BMXI=BMXI+1
+43 SET ^BMXTMP($JOB,BMXI)=BMXN_U_BMXDOB_U_BMXFAC_U_BMXNAM_U_BMXSEX_$CHAR(30)
+44 QUIT
End DoDot:1
+45 SET BMXI=BMXI+1
+46 SET ^BMXTMP($JOB,BMXI)=$CHAR(31)
+47 QUIT
+48 ;
ERR(BMXID,BMXERR) ;Error processing
+1 KILL ^BMXTMP($JOB)
+2 SET ^BMXTMP($JOB,0)="I00030ERRORID^T00030ERRORMSG"_$CHAR(30)
+3 SET ^BMXTMP($JOB,1)=BMXID_"^"_BMXERR_$CHAR(30)
+4 SET ^BMXTMP($JOB,2)=$CHAR(31)
+5 QUIT
+6 ;
ETRAP ;EP Error trap entry
+1 DO ^%ZTER
+2 DO ERR(99,"BMXRPC9 Error: "_$GET(%ZTERROR))
+3 QUIT
+4 ;
TEST NEW OUT
SET OUT=""
DO ADO(.OUT,2160010,"1",(".01|A,A"_$CHAR(30)_".02|M"_$CHAR(30)_".03|1/5/1946"_$CHAR(30)_".04|SAN XAVIER"_$CHAR(31)))
WRITE !,OUT
+1 QUIT
+2 ;
ADOD(OUT,FILE,IEN,DATA) ;
+1 ;
+2 ;D DEBUG^%Serenji("ADOD^BMXRPC9(.OUT,FILE,IEN,DATA)")
+3 ;
+4 QUIT
+5 ;
ADO(OUT,FILE,IEN,DATA) ; RPC CALL: OUT = OUTBOUND MESSAGE, FILE = FILEMAN FILE NUMBER, IEN = FILE INTERNAL ENTRY NUMBER, DATA = DATA STRING
+1 NEW OREF,CREF,DIC,DIE,DA,DR,X,Y,%,FLD,CNT,FNO,VAL,TFLG,DFLG,TOT,UFLG,XTFLG,GTFLG,GDFLG
+2 SET OUT=""
SET FLD=""
SET GTFLG=0
SET GDFLG=0
+3 SET IEN=$GET(IEN)
+4 ; GLOBAL DELETE FLAG
IF $EXTRACT(IEN)="-"
SET IEN=$EXTRACT(IEN,2,99)
SET GDFLG=1
+5 ; GLOBAL TRANSACTION FLAG, ROLLBACK IF ANY FIELD FAILS TO UPDATE
IF $EXTRACT(IEN)="+"
SET IEN=$EXTRACT(IEN,2,99)
SET GTFLG=1
+6 IF IEN="Add"!(IEN="ADD")
SET IEN=""
+7 IF '$DATA(^DIC(+$GET(FILE),0,"GL"))
SET OUT="Update cancelled. Invalid FILE number"
QUIT
+8 SET OREF=^DIC(FILE,0,"GL")
IF '$LENGTH(OREF)
SET OUT="Update cancelled. Invalid file definition"
QUIT
+9 ; CONVERT OREF TO CREF
SET CREF=$EXTRACT(OREF,1,$LENGTH(OREF)-1)
IF $EXTRACT(OREF,$LENGTH(OREF))=","
SET CREF=CREF_")"
+10 IF IEN
IF '$DATA(@CREF@(IEN))
SET OUT="Update cancelled. Invalid IEN"
QUIT
+11 IF 'GDFLG
IF IEN
IF (DATA["-.01|"!(DATA[".01|@"))
SET GDFLG=1
+12 IF GDFLG
IF 'IEN
SET OUT="Deletion cancelled. Missing IEN"
QUIT
+13 IF GDFLG
DO DIK(OREF,IEN)
SET OUT="Record deleted|"_IEN
QUIT
+14 ; UPDATE FLAG: ADD OR EDIT
SET UFLG=$SELECT($GET(IEN):"E",1:"A")
+15 IF '$LENGTH($GET(DATA))
SET OUT="Update cancelled. Missing/invalid data string"
QUIT
+16 SET TOT=$LENGTH(DATA,$CHAR(30))
IF 'TOT
SET OUT="Update cancelled. Missing data string"
QUIT
+17 ; BUILD PRIMARY FIELD ARRAY
FOR CNT=1:1:TOT
SET DATA(CNT)=$PIECE(DATA,$CHAR(30),CNT)
+18 SET %=DATA(1)
IF %=""!(%=$CHAR(31))
SET OUT="Update cancelled. Missing data string"
QUIT
+19 ; STRIP OFF END OF FILE MARKER
SET %=DATA(CNT)
IF %[$CHAR(31)
SET %=$PIECE(%,$CHAR(31),1)
SET DATA(CNT)=%
+20 ; BUILD SECONDARY FIELD ARRAY
FOR CNT=1:1:TOT
SET X=DATA(CNT)
IF $LENGTH(X)
Begin DoDot:1
+21 SET TFLG=0
SET DFLG=0
+22 IF $EXTRACT(X)="+"
SET TFLG=1
SET X=$EXTRACT(X,2,999)
SET $PIECE(FLD,U)=1
+23 IF $EXTRACT(X)="-"
SET DFLG=1
SET X=$EXTRACT(X,2,999)
+24 SET FNO=$PIECE(X,"|")
SET VAL=$PIECE(X,"|",2)
+25 IF '$DATA(^DD(FILE,+$GET(FNO),0))
IF $LENGTH(OUT)
SET OUT=OUT_"~"
SET OUT=OUT_FNO_"|Invalid field number"
QUIT
+26 ; CANT DELETE IF A VALUE IS SENT
IF DFLG
IF VAL'=""
IF $LENGTH(OUT)
SET OUT=OUT_"~"
SET OUT=OUT_FNO_"|Invalid deletion syntax"
QUIT
+27 ; SYNC DFLG AND VAL
IF DFLG!(VAL="")
SET VAL="@"
+28 ; SYNC DFLG AND VAL
IF VAL="@"
SET DFLG=1
+29 SET FLD(FNO)=VAL_U_TFLG_U_DFLG
+30 ;
IF FNO=.01
IF TFLG
SET $PIECE(FLD,U,2)=1
+31 QUIT
End DoDot:1
+32 ; CAN'T DELETE A RECORD WITHOUT A VALID IEN
IF $PIECE($GET(FLD(.01)),U,3)
IF UFLG="A"
SET OUT="Record deletion cancelled. Missing IEN"
QUIT
DELREC ; DELETE THE RECORD
IF $PIECE($GET(FLD(.01)),U,3)
DO DIK(OREF,IEN)
SET OUT="OK"
QUIT
+1 ; CAN'T ADD A RECORD WITHOUT A VALID .01 FIELD
IF UFLG="A"
IF '$LENGTH($PIECE($GET(FLD(.01)),U))
SET OUT="Record addition cancelled. Missing .01 field"
QUIT
ADDREC ; ADD A NEW ENTRY TO A FILE
IF UFLG="A"
DO ADD(OREF)
QUIT
EDITREC ; EDIT AN EXISTING RECORD
IF UFLG="E"
DO EDIT(OREF,IEN)
QUIT
+1 QUIT
+2 ;
DIK(DIK,DA) ; DELETE A RECORD
+1 DO ^DIK
+2 DO ^XBFMK
+3 QUIT
+4 ;
ADD(DIC) ; ADD A NEW ENTRY TO A FILE
+1 NEW X,Y
+2 SET X=""""_$PIECE($GET(FLD(.01)),U)_""""
+3 SET DIC(0)="L"
+4 DO ^DIC
+5 IF Y=-1
SET OUT="Unable to add a new record"
GOTO AX
+6 IF $ORDER(FLD(.01))
DO EDIT(DIC,+Y)
QUIT
+7 SET OUT="OK"_"|"_+Y
AX DO ^XBFMK
+1 QUIT
+2 ;
EDIT(DIE,DA) ; EDIT AN EXISTING RECORD
+1 NEW DR,RFLG,ERR,FNO,VAL,TFLG,RESULT,MSG,DIERR,DISYS
+2 ;HMW Changed to include .01 in DR string
SET FNO=$ORDER(FLD(.01),-1)
SET DR=""
+3 IF UFLG="A"
SET OUT="New record added|"_DA
+4 ; CHECK EA FIELD AND BUILD THE DR STRING AND ERROR STRING
FOR
SET FNO=$ORDER(FLD(FNO))
IF 'FNO
QUIT
SET X=FLD(FNO)
IF $LENGTH(X)
Begin DoDot:1
+5 SET VAL(FNO)=$PIECE(X,U)
SET TFLG=$PIECE(X,U,2)
IF '$LENGTH(VAL(FNO))
QUIT
+6 KILL ERR,RESULT
+7 IF VAL(FNO)="@"!(VAL(FNO)="")
SET RESULT="@"
+8 IF '$TEST
DO CHK^DIE(FILE,FNO,"",VAL(FNO),.RESULT,"ERR")
+9 IF RESULT=U
Begin DoDot:2
+10 SET MSG=$GET(ERR("DIERR",1,"TEXT",1),"Failed FileMan data validation")
+11 IF $LENGTH(OUT)
SET OUT=OUT_"~"
+12 IF TFLG!GTFLG
SET RFLG=1
SET OUT=FNO_"|"_MSG
QUIT
+13 SET OUT=OUT_FNO_"|"_MSG
+14 QUIT
End DoDot:2
QUIT
+15 SET VAL(FNO)=RESULT
+16 IF $LENGTH(DR)
SET DR=DR_";"
+17 ; BUILD DR STRING
SET DR=DR_FNO_"////^S X=VAL("_FNO_")"
+18 QUIT
End DoDot:1
IF $GET(RFLG)
QUIT
+19 ; TRANSACTION ROLLBACK FLAG IS SET, ENTRY DELETED (ADD MODE) OR UPDATE CANCELLED (EDIT MODE)
IF $GET(RFLG)
IF UFLG="A"
DO DIK(DIE,DA)
SET OUT="Record update cancelled"_"|"_OUT
GOTO EX
+20 ; SUCCESS!!!!
LOCK +@CREF@(DA):2
IF $TEST
DO ^DIE
LOCK -@CREF@(DA)
IF OUT["valid"
GOTO EX
SET OUT="OK"
IF UFLG="A"
SET OUT=OUT_"|"_DA
GOTO EX
+21 ; FILE LOCKED. UNABLE TO UPDATE
SET OUT="Update cancelled. File locked"
+22 ; ROLLBACK THE NEW RECORD
IF $LENGTH(FLD)
IF UFLG="A"
DO DIK(DIE,DA)
EX ; CLEANUP
DO ^XBFMK
+1 QUIT
+2 ;
