BMXADOF ; IHS/CIHA/GIS - RPC CALL FOR EXTENDED FUNCTIONALITY OF BMXNet UTILITIES ; 04 Jun 2010 3:14 PM
;;4.0;BMX;**4**;JUN 28, 2010;Build 4
; THIS IS THE ADO RECORDSET FILER: ADO -> FILEMAN
; VISIT FILE UPDATES REPRESENT A SPECIAL CASE HTAT IS MANAGED IN BMXADOF1
; INCLUDES TRANSACTION CONTROLS
;
;
;
N DAS,FILE,DATA,OUT S DAS=7,FILE=19707.82,DATA="2.02|120/83" D FILE(.OUT,FILE,DAS,DATA) W !,OUT Q
;
FILED(OUT,FILE,DAS,DATA) ; RPC CALL: UNIVERSAL FILEMAN RECORD UPDATER UTILITY
; D DEBUG^%Serenji("FILED^BMXADOF(.OUT,FILE,DAS,DATA)") ; DEBUGGER ENTRY POINT
Q
;
FILEX(OUT,FILE,DAS,DATA) ; EP - RPC CALL: INSURES THAT BMXIEN IS VALID - MOJO ONLY
I '$L($G(DATA)) D
. S DATA="",%=""
. F S %=$O(DATA(%)) Q:'% S DATA=DATA_DATA(%) ; CONVERT DATA ARRAY INTO A DATA STRING
. Q
I '$L(DATA) Q
I DATA["999|" S DAS=+$P(DATA,"999|",2) I 'DAS S DAS="" ; FORCE NEW ENTRY
D FILE(.OUT,FILE,$G(DAS),DATA)
Q
;
FILE(OUT,FILE,DAS,DATA) ;EP - RPC CALL: UNIVERSAL FILEMAN RECORD UPDATER UTILITY
;
; OUT = OUTBOUND MESSAGE RETURNED TO CALLINING APP. 'OK'=SUCCESSFUL TRANSACTION, 'OK|5' NEW RECORD DAS=5 ADDED
; IF TRANSACTION FAILS, AN ERROR MESSAGE IS PASSED
; FILE = VALID FILEMAN FILE OR SUB-FILE NUMBER - WHERE UPDATE IS TO OCCUR
; DAS = THE DA STRING - TYPICALLY THE FILE INTERNAL ENTRY NUMBER OF THE RECORD TO BE UPDATED
; IF THIS IS A SUB-FILE, DAS MUST BE PRECEDED BY PARENT DAS(S) IN COMMA SEPARATED STRING - TOP TO BOTTOM ORDER
; DAS MAY BE PRECEDED BY '+' = ALL FIELDS ARE MANDATORY (REQD FOR TRANSACTION) OR '-' = DELETE THIS ENTRY
; IF DAS STRING = NULL OR = '+', THIS MEANS ADD A NEW RECORD WITH DATA SUPPLIED IN DATA PARAMETER
; EXAMPLES OF DAS STRINGS: '1' (EDIT RECORD #1), '5,2,-7' (DELETE RECORD #7 IN 3RD LEVEL SUBFILE)
; DATA = DATA STRING OR ARRAY REFERENCE. DATA CAN BE PASSED USING THE .PARAM SYNTAX
; DATA STRING FORMAT: FIELD#|VALUE_$C(30)_FIELD#|VALUE_$C(30)_...FIELD#|VALUE_$C(30)
; $C(30) [AKA EOR] IS THE DATA ELEMENT SEPARATOR
; $C(30) IS USED AS THE DATA DELIMITER BECAUSE OTHER CHARACTERS LIKE '^' COULD APPEAR IN THE VALUE PIECE!
; EA FIELD# MAY BE PRECEED BY '+' = MANDATORY (REQD FOR TRANSACTION) OR '-' = DELETE THE VALUE OF THIS FIELD
; EXAMPLE: ".03|1/5/46"_EOR_"-.02|"_EOR_"+.09|139394444"_EOR NOTE -.02| IS SAME AS .02|@ OR .02|
; '+' IN FRONT OF THE DAS IS THE SAME AS PUTTING A '+' IN FRONT OF EVERY FIELD# IN THE DATA STRING
;
N VENDUZ,VUZ
M VENDUZ=DUZ S VUZ=$C(68,85,90)
N OREF,CREF,DIC,DIE,DA,DR,X,Y,%,I,FLD,CNT,FNO,VAL,@VUZ,TFLG,DFLG,TOT,UFLG,XTFLG,GTFLG,GDFLG,LVLS,IENS
I $G(FILE)=9000010 N AUPNPAT,AUPNDOB,AUPNDOD,AUPNVSIT,AUPNTALK,APCDOVRR S (APCDOVRR,AUPNTALK)=1 ; THE VISIT FILE IS UPDATED IN THIS TRANSACTION
X ("M "_$C(68,85,90)_"=VENDUZ S "_$C(68,85,90)_"(0)="_$C(34,64,34)) K VENDUZ ; ELININATES PERMISSION PROBLEMS
S OUT="",FLD="",GTFLG=0,GDFLG=0
S X="MERR^BMXADOF",@^%ZOSF("TRAP") ; SET MUMPS ERROR TRAP
I '$D(^DD(+$G(FILE))) S OUT="Invalid file number" Q ; FILE # MUST BE VALID
S DAS=$G(DAS) I $E(DAS)="," S DAS=$E(DAS,2,99) ; ACCURATE IF NON SUB-FILE DAS STRING DOSN'T CONTAIN A ","
S LVLS=$L(DAS,",")
S %=FILE F CNT=1:1 S %=$G(^DD(%,0,"UP")) I '% Q ; COUNT FILE/SUB-FILE LEVELS IN THE DATA DICTIONARY
I LVLS'=CNT S OUT="Invalid DAS string" Q ; LEVELS IN DAS STRING MUST MATCH LEVELS IN THE DATA DICTIONARY
I $E(DAS)="-" S DAS=$E(DAS,2,99),GDFLG=1 ; GLOBAL DELETE FLAG
I $E(DAS)="+" S DAS=$E(DAS,2,99),GTFLG=1 ; GLOBAL TRANSACTION FLAG, ROLLBACK IF ANY FIELD FAILS TO UPDATE
I LVLS>1 F I=1:1:LVLS D I DAS="ERR" S OUT="Invalid DAS string" Q ; MAKE DAS ARRAY. MIRRORS THE DA() ARRAY
. I I=LVLS S DAS=$P(DAS,",",I) Q ; SET DAS OF SUBFILE
. S %=$P(DAS,",",I) I '% S DAS="ERR" Q
. S DAS(LVLS-I)=% ; SET DAS(S) OF PARENT FILE(S). LIKE DA(), THE LARGER THE DAS SUBSCRIPT, THE HIGHER THE LEVEL
. Q
I DAS="ERR" S OUT="Update cancelled. Invalid DAS string" Q
I DAS="Add"!(DAS="ADD") S DAS=""
S %=$E(DAS) I %="-" S GDFLG=1,DAS=$E(DAS,2,99) ; YET ANOTHER WAY TO SET GLOBAL DELETE FLAG
S %=$$REF(FILE,.DAS) ; GET OPEN REF, CLOSED REF, AND IENS STRING
S OREF=$P(%,"|"),CREF=$P(%,"|",2),IENS=$P(%,"|",3) I $L(OREF),$L(CREF)
E S OUT="Update cancelled. Invalid file definition/global reference" Q ; ERROR REPORT
I DAS,'$D(@CREF@(DAS)) S OUT="Update cancelled. Invalid DAS" Q ; IF THERE IS AN DAS, IT MUST BE VALID
I '$G(DAS),FILE=9000010,'$$VVAR^BMXADOF2(DATA) Q ; VISIT FILE ADD REQUIRES THAT SPECIAL VARIABLES BE PRESENT AND VALID
I 'GDFLG,DAS,DATA[".01|@" S GDFLG=1 ; ALTERNATE WAY TO SET GLOBAL DELETE FLAG: REMOVE .01 FIELD
I GDFLG,'DAS S OUT="Deletion cancelled. Missing DAS" Q ; CAN'T DO DELETE WITHOUT AN DAS
I GDFLG D DIK(OREF,DAS) S OUT="Record deleted|"_DAS Q ; DELETE AND QUIT
S UFLG=$S($G(DAS):"E",1:"A") ; SET UPDATE FLAG: ADD OR EDIT
I '$L($G(DATA)) D I '$L($G(DATA)) S OUT="Update cancelled. Missing/invalid data string" Q ; COMPRESS DATA ARRAY INTO A SINGLE STRING
. S DATA="",%=""
. F S %=$O(DATA(%)) Q:'% S DATA=DATA_DATA(%) ; CONVERT DATA ARRAY INTO A DATA STRING
. Q
S %=$L(DATA) S %=$E(DATA,%-1,%) D ; CHECK FOR PROPER TERMINATION OF DATA STRING
. I %=$C(30,31) Q ; PROPER TERMINATION
. I $E(%,2)=$C(30) S DATA=DATA_$C(31) Q
. I $E(%,2)=$C(31) S DATA=$E(DATA,1,$L(DATA-1))_$C(30,31)
. S DATA=DATA_$C(30,31)
. Q
S TOT=$L(DATA,$C(30)) I 'TOT S OUT="Update cancelled. Missing data string" Q
SPEC S DATA=$$SPEC^BMXADOFS(FILE,DATA,UFLG) ; BASED ON FILE IEN, SPECIAL MODS MAY BE MADE TO THE DATA STRING
S TOT=$L(DATA,$C(30)) I 'TOT S OUT="Update cancelled. SPEC analysis failed." Q
F CNT=1:1:TOT S %=$P(DATA,$C(30),CNT) I $L(%) S DATA(CNT)=% ; BUILD PRIMARY FIELD ARRAY
S %=$G(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=$G(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 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 DAS" Q ; CAN'T DELETE A RECORD WITHOUT A VALID DAS
I $P($G(FLD(.01)),U,3)!($G(GDFLG)) S UFLG="D" ; DELETION
DELREC I UFLG="D" D DIK(OREF,DAS) 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
DINUM I UFLG="A",$G(^DD(FILE,.01,0))["DINUM=X" D ; IF DINUM'D RECORD EXISTS, SWITCH TO MOD MODE
. S %=FLD(.01)
. I $E(%)="`" S %=+$E(%,2,99)
. I '$D(@CREF@(%,0)) Q ; OK TO ADD BRAND NEW RECORD BUT EXISTING RECORDS MUST BE EDITED
. K FLD(.01)
. S DAS=%,UFLG="E"
. Q
ADDREC I UFLG="A" D ADD(OREF) Q ; ADD A NEW ENTRY TO A FILE
EDITREC I UFLG="E" D EDIT(OREF,DAS) Q ; EDIT AN EXISTING RECORD
Q
;
DIK(DIK,DA) ; DELETE A RECORD
; PATCHED BY GIS 9/28/04 TO FIX PROBLEMS WITH SUBFILE DELETION
I '$G(DAS(1)) G DIK1 ; CHECK FOR SUBFILE DELETION
N DA,IENS,I,DIK
I '$G(FILE) Q
S I=0,IENS=DAS_","
M DA=DAS
F S I=$O(DAS(I)) Q:'I S IENS=IENS_DAS(I)_","
S DIK=$$ROOT^DILFD(FILE,IENS) I '$L(DIK) Q
DIK1 D ^DIK
D ^XBFMK
Q
;
ADD(DIC) ; ADD A NEW ENTRY TO A FILE
N X,Y,%,DA,DN,UP,SB,DNODE,ERR
S X=$P($G(FLD(.01)),U) I '$L(X) S OUT="Unable to add a new record" Q
;S X=$$POINT(FILE,.01,X) ; ADD ACCENT GRAV IF NECESSARY
;S X=""""_X_"""" ; FORCE A NEW ENTRY
S DIC(0)="L"
I $O(DAS(0)) D I $G(ERR) S Y=-1 G AFAIL ; GET DIC("P") IF NECESSARY
. S %=0 F S %=$O(DAS(%)) Q:'% S DA(%)=DAS(%) ; CREATE THE DA ARRAY
. S UP=$G(^DD(FILE,0,"UP")) I 'UP S ERR=1 Q
. S SB=$O(^DD(UP,"SB",FILE,0)) I 'SB S ERR=1 Q
. S DIC("P")=$P($G(^DD(UP,SB,0)),U,2) I '$L(DIC("P")) S ERR=1 Q
. S DN=DIC_"1,0)" I $D(DN) Q
. S @DN=(U_DIC("P")_U_U) ; CREATE THE DICTIONARY NODE
. Q
ADIC ;D ^DIC
K DO,DD D FILE^DICN
AFAIL I Y=-1 S OUT="Unable to add a new record" G AX
I $O(FLD(0)) 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,SF,APCDALVR
S FNO=0,DR="",APCDALVR=""
I UFLG="A" S OUT="OK 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
. S SF=$$WP(FILE,FNO)
. I SF D WORD(FILE,DA,FNO,CREF,VAL(FNO)) Q ; WORD PROCESSING FIELDS MANAGED SEPARATELY
. S VAL(FNO)=$$POINT(FILE,FNO,VAL(FNO)) ; ADD ACCENT GRAV IF NECESSARY
. K ERR,RESULT
. I VAL(FNO)="@"!(VAL(FNO)="") S RESULT="@"
. I FNO=.01,UFLG="A" S:$E(VAL(.01))="`" VAL(.01)=$E(VAL(.01),2,999) Q ; NO NEED TO EDIT THE .01 FIELD OF A RECORD THAT HAS JUST BEEN CREATED
. I FILE\1=9000010,$L($P(FILE,".",2))=2,UFLG="E",(FNO=.02!(FNO=.03)) Q ; CAN'T EDIT EXISTING PT AND VISIT FIELDS OF V FILES
. I FILE\1=9000010,$L($P(FILE,".",2))=2,UFLG="A",FNO=.03,VAL(.03)?1"`"1.N S %=+$E(VAL(.03),2,99) I $D(^AUPNVSIT(%,0)) S RESULT=% G E1
. I FILE=9000011,FNO=.07,VAL(.07)?1.N S RESULT=VAL(.07) G E1 ; THE VALIDITY CHECK FAILS - SO BYPASS THIS
CHK . I VAL(FNO)'="@" D CHK^DIE(FILE,FNO,"",VAL(FNO),.RESULT,.ERR)
E1 . 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_";"
. I RESULT="@" S DR=DR_FNO_"////@" Q ; DELETE THIS VALUE
. 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)
S %=0 F S %=$O(DAS(%)) Q:'% S DA(%)=DAS(%) ; JUST IN CASE THIS IS A MILTIPLE, CREATE THE DA ARRAY
DIE 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
;
REF(FILE,DAS) ; GIVEN A FILE/SUBFILE NUMBER & DAS ARRAY, RETURN THE FM GLOBAL REFERENCE INFO: OREF|CREF|IENS
N OREF,CREF,IENS,I,X
S IENS=$$IENS^DILF(.DAS) I '$L(IENS) Q ""
S OREF=$$ROOT^DILFD(FILE,IENS) I '$L(OREF) Q ""
S CREF=$$CREF^DILF(OREF) I '$L(CREF) Q ""
Q (OREF_"|"_CREF_"|"_IENS)
;
POINT(FILE,FNO,VAL) ; ADD ACCENT GRAV IF NECESSARY
I $E(VAL)="`" Q VAL
I $P($G(^DD(FILE,FNO,0)),U,2)["P",VAL=+VAL,VAL\1=VAL S VAL="`"_VAL
Q VAL
;
WP(FILE,FLD) ; RETURN THE SUBFILE NUMBER IF IT IS A WORD PROCESSING FIELD
N SF,DTYPE
S SF=$P($G(^DD(+$G(FILE),+$G(FLD),0)),U,2) I 'SF Q 0
S DTYPE=$P($G(^DD(SF,.01,0)),U,2)
I DTYPE["W" Q SF
Q 0
;
WORD(FILE,DA,FLD,CREF,VAL) ; SUFF TEXT ENTRY INTO THE WP MULTIPLE FIELD
N SS,TOT,A,B,I
S SS=+$P($G(^DD(FILE,FLD,0)),U,4) I SS="" Q
I VAL="@"!(VAL="") K @CREF@(DA,SS) Q ; DELETE THE WP RECORD: REMOVE DICTIONARY NODE AND DATA
S TOT=0
F Q:'$L(VAL) D
. S A=$E(VAL,1,80),VAL=$E(VAL,81,999999) ; PEEL OFF AN 80 CHARACTER DATA BLOCK FROM THE FRONT OF THE TEXT STRING
. I $L(A) S TOT=TOT+1,B(TOT)=A ; BUILD THE TEMP ARRAY
. Q
I '$D(B(1)) Q ; NOTHING TO STORE SO QUIT
S @CREF@(DA,SS,0)="^^"_TOT_U_TOT_U_DT ; SET DICTIONARY NODE
F I=1:1:TOT S @CREF@(DA,SS,I,0)=B(I) ; SET DATA NODES
Q
;
MERR ; MUMPS ERROR TRAP
N ERR,X
X ("S X=$"_"ZE")
S ERR="M ERROR: "_X
S OUT=ERR
Q
;
BMXADOF ; IHS/CIHA/GIS - RPC CALL FOR EXTENDED FUNCTIONALITY OF BMXNet UTILITIES ; 04 Jun 2010 3:14 PM
+1 ;;4.0;BMX;**4**;JUN 28, 2010;Build 4
+2 ; THIS IS THE ADO RECORDSET FILER: ADO -> FILEMAN
+3 ; VISIT FILE UPDATES REPRESENT A SPECIAL CASE HTAT IS MANAGED IN BMXADOF1
+4 ; INCLUDES TRANSACTION CONTROLS
+5 ;
+6 ;
+7 ;
+8 NEW DAS,FILE,DATA,OUT
SET DAS=7
SET FILE=19707.82
SET DATA="2.02|120/83"
DO FILE(.OUT,FILE,DAS,DATA)
WRITE !,OUT
QUIT
+9 ;
FILED(OUT,FILE,DAS,DATA) ; RPC CALL: UNIVERSAL FILEMAN RECORD UPDATER UTILITY
+1 ; D DEBUG^%Serenji("FILED^BMXADOF(.OUT,FILE,DAS,DATA)") ; DEBUGGER ENTRY POINT
+2 QUIT
+3 ;
FILEX(OUT,FILE,DAS,DATA) ; EP - RPC CALL: INSURES THAT BMXIEN IS VALID - MOJO ONLY
+1 IF '$LENGTH($GET(DATA))
Begin DoDot:1
+2 SET DATA=""
SET %=""
+3 ; CONVERT DATA ARRAY INTO A DATA STRING
FOR
SET %=$ORDER(DATA(%))
IF '%
QUIT
SET DATA=DATA_DATA(%)
+4 QUIT
End DoDot:1
+5 IF '$LENGTH(DATA)
QUIT
+6 ; FORCE NEW ENTRY
IF DATA["999|"
SET DAS=+$PIECE(DATA,"999|",2)
IF 'DAS
SET DAS=""
+7 DO FILE(.OUT,FILE,$GET(DAS),DATA)
+8 QUIT
+9 ;
FILE(OUT,FILE,DAS,DATA) ;EP - RPC CALL: UNIVERSAL FILEMAN RECORD UPDATER UTILITY
+1 ;
+2 ; OUT = OUTBOUND MESSAGE RETURNED TO CALLINING APP. 'OK'=SUCCESSFUL TRANSACTION, 'OK|5' NEW RECORD DAS=5 ADDED
+3 ; IF TRANSACTION FAILS, AN ERROR MESSAGE IS PASSED
+4 ; FILE = VALID FILEMAN FILE OR SUB-FILE NUMBER - WHERE UPDATE IS TO OCCUR
+5 ; DAS = THE DA STRING - TYPICALLY THE FILE INTERNAL ENTRY NUMBER OF THE RECORD TO BE UPDATED
+6 ; IF THIS IS A SUB-FILE, DAS MUST BE PRECEDED BY PARENT DAS(S) IN COMMA SEPARATED STRING - TOP TO BOTTOM ORDER
+7 ; DAS MAY BE PRECEDED BY '+' = ALL FIELDS ARE MANDATORY (REQD FOR TRANSACTION) OR '-' = DELETE THIS ENTRY
+8 ; IF DAS STRING = NULL OR = '+', THIS MEANS ADD A NEW RECORD WITH DATA SUPPLIED IN DATA PARAMETER
+9 ; EXAMPLES OF DAS STRINGS: '1' (EDIT RECORD #1), '5,2,-7' (DELETE RECORD #7 IN 3RD LEVEL SUBFILE)
+10 ; DATA = DATA STRING OR ARRAY REFERENCE. DATA CAN BE PASSED USING THE .PARAM SYNTAX
+11 ; DATA STRING FORMAT: FIELD#|VALUE_$C(30)_FIELD#|VALUE_$C(30)_...FIELD#|VALUE_$C(30)
+12 ; $C(30) [AKA EOR] IS THE DATA ELEMENT SEPARATOR
+13 ; $C(30) IS USED AS THE DATA DELIMITER BECAUSE OTHER CHARACTERS LIKE '^' COULD APPEAR IN THE VALUE PIECE!
+14 ; EA FIELD# MAY BE PRECEED BY '+' = MANDATORY (REQD FOR TRANSACTION) OR '-' = DELETE THE VALUE OF THIS FIELD
+15 ; EXAMPLE: ".03|1/5/46"_EOR_"-.02|"_EOR_"+.09|139394444"_EOR NOTE -.02| IS SAME AS .02|@ OR .02|
+16 ; '+' IN FRONT OF THE DAS IS THE SAME AS PUTTING A '+' IN FRONT OF EVERY FIELD# IN THE DATA STRING
+17 ;
+18 NEW VENDUZ,VUZ
+19 MERGE VENDUZ=DUZ
SET VUZ=$CHAR(68,85,90)
+20 NEW OREF,CREF,DIC,DIE,DA,DR,X,Y,%,I,FLD,CNT,FNO,VAL,@VUZ,TFLG,DFLG,TOT,UFLG,XTFLG,GTFLG,GDFLG,LVLS,IENS
+21 ; THE VISIT FILE IS UPDATED IN THIS TRANSACTION
IF $GET(FILE)=9000010
NEW AUPNPAT,AUPNDOB,AUPNDOD,AUPNVSIT,AUPNTALK,APCDOVRR
SET (APCDOVRR,AUPNTALK)=1
+22 ; ELININATES PERMISSION PROBLEMS
XECUTE ("M "_$CHAR(68,85,90)_"=VENDUZ S "_$CHAR(68,85,90)_"(0)="_$CHAR(34,64,34))
KILL VENDUZ
+23 SET OUT=""
SET FLD=""
SET GTFLG=0
SET GDFLG=0
+24 ; SET MUMPS ERROR TRAP
SET X="MERR^BMXADOF"
SET @^%ZOSF("TRAP")
+25 ; FILE # MUST BE VALID
IF '$DATA(^DD(+$GET(FILE)))
SET OUT="Invalid file number"
QUIT
+26 ; ACCURATE IF NON SUB-FILE DAS STRING DOSN'T CONTAIN A ","
SET DAS=$GET(DAS)
IF $EXTRACT(DAS)=","
SET DAS=$EXTRACT(DAS,2,99)
+27 SET LVLS=$LENGTH(DAS,",")
+28 ; COUNT FILE/SUB-FILE LEVELS IN THE DATA DICTIONARY
SET %=FILE
FOR CNT=1:1
SET %=$GET(^DD(%,0,"UP"))
IF '%
QUIT
+29 ; LEVELS IN DAS STRING MUST MATCH LEVELS IN THE DATA DICTIONARY
IF LVLS'=CNT
SET OUT="Invalid DAS string"
QUIT
+30 ; GLOBAL DELETE FLAG
IF $EXTRACT(DAS)="-"
SET DAS=$EXTRACT(DAS,2,99)
SET GDFLG=1
+31 ; GLOBAL TRANSACTION FLAG, ROLLBACK IF ANY FIELD FAILS TO UPDATE
IF $EXTRACT(DAS)="+"
SET DAS=$EXTRACT(DAS,2,99)
SET GTFLG=1
+32 ; MAKE DAS ARRAY. MIRRORS THE DA() ARRAY
IF LVLS>1
FOR I=1:1:LVLS
Begin DoDot:1
+33 ; SET DAS OF SUBFILE
IF I=LVLS
SET DAS=$PIECE(DAS,",",I)
QUIT
+34 SET %=$PIECE(DAS,",",I)
IF '%
SET DAS="ERR"
QUIT
+35 ; SET DAS(S) OF PARENT FILE(S). LIKE DA(), THE LARGER THE DAS SUBSCRIPT, THE HIGHER THE LEVEL
SET DAS(LVLS-I)=%
+36 QUIT
End DoDot:1
IF DAS="ERR"
SET OUT="Invalid DAS string"
QUIT
+37 IF DAS="ERR"
SET OUT="Update cancelled. Invalid DAS string"
QUIT
+38 IF DAS="Add"!(DAS="ADD")
SET DAS=""
+39 ; YET ANOTHER WAY TO SET GLOBAL DELETE FLAG
SET %=$EXTRACT(DAS)
IF %="-"
SET GDFLG=1
SET DAS=$EXTRACT(DAS,2,99)
+40 ; GET OPEN REF, CLOSED REF, AND IENS STRING
SET %=$$REF(FILE,.DAS)
+41 SET OREF=$PIECE(%,"|")
SET CREF=$PIECE(%,"|",2)
SET IENS=$PIECE(%,"|",3)
IF $LENGTH(OREF)
IF $LENGTH(CREF)
+42 ; ERROR REPORT
IF '$TEST
SET OUT="Update cancelled. Invalid file definition/global reference"
QUIT
+43 ; IF THERE IS AN DAS, IT MUST BE VALID
IF DAS
IF '$DATA(@CREF@(DAS))
SET OUT="Update cancelled. Invalid DAS"
QUIT
+44 ; VISIT FILE ADD REQUIRES THAT SPECIAL VARIABLES BE PRESENT AND VALID
IF '$GET(DAS)
IF FILE=9000010
IF '$$VVAR^BMXADOF2(DATA)
QUIT
+45 ; ALTERNATE WAY TO SET GLOBAL DELETE FLAG: REMOVE .01 FIELD
IF 'GDFLG
IF DAS
IF DATA[".01|@"
SET GDFLG=1
+46 ; CAN'T DO DELETE WITHOUT AN DAS
IF GDFLG
IF 'DAS
SET OUT="Deletion cancelled. Missing DAS"
QUIT
+47 ; DELETE AND QUIT
IF GDFLG
DO DIK(OREF,DAS)
SET OUT="Record deleted|"_DAS
QUIT
+48 ; SET UPDATE FLAG: ADD OR EDIT
SET UFLG=$SELECT($GET(DAS):"E",1:"A")
+49 ; COMPRESS DATA ARRAY INTO A SINGLE STRING
IF '$LENGTH($GET(DATA))
Begin DoDot:1
+50 SET DATA=""
SET %=""
+51 ; CONVERT DATA ARRAY INTO A DATA STRING
FOR
SET %=$ORDER(DATA(%))
IF '%
QUIT
SET DATA=DATA_DATA(%)
+52 QUIT
End DoDot:1
IF '$LENGTH($GET(DATA))
SET OUT="Update cancelled. Missing/invalid data string"
QUIT
+53 ; CHECK FOR PROPER TERMINATION OF DATA STRING
SET %=$LENGTH(DATA)
SET %=$EXTRACT(DATA,%-1,%)
Begin DoDot:1
+54 ; PROPER TERMINATION
IF %=$CHAR(30,31)
QUIT
+55 IF $EXTRACT(%,2)=$CHAR(30)
SET DATA=DATA_$CHAR(31)
QUIT
+56 IF $EXTRACT(%,2)=$CHAR(31)
SET DATA=$EXTRACT(DATA,1,$LENGTH(DATA-1))_$CHAR(30,31)
+57 SET DATA=DATA_$CHAR(30,31)
+58 QUIT
End DoDot:1
+59 SET TOT=$LENGTH(DATA,$CHAR(30))
IF 'TOT
SET OUT="Update cancelled. Missing data string"
QUIT
SPEC ; BASED ON FILE IEN, SPECIAL MODS MAY BE MADE TO THE DATA STRING
SET DATA=$$SPEC^BMXADOFS(FILE,DATA,UFLG)
+1 SET TOT=$LENGTH(DATA,$CHAR(30))
IF 'TOT
SET OUT="Update cancelled. SPEC analysis failed."
QUIT
+2 ; BUILD PRIMARY FIELD ARRAY
FOR CNT=1:1:TOT
SET %=$PIECE(DATA,$CHAR(30),CNT)
IF $LENGTH(%)
SET DATA(CNT)=%
+3 SET %=$GET(DATA(1))
IF %=""!(%=$CHAR(31))
SET OUT="Update cancelled. Missing data string"
QUIT
+4 ; STRIP OFF END OF FILE MARKER
SET %=DATA(CNT)
IF %[$CHAR(31)
SET %=$PIECE(%,$CHAR(31),1)
SET DATA(CNT)=%
+5 ; BUILD SECONDARY FIELD ARRAY
FOR CNT=1:1:TOT
SET X=$GET(DATA(CNT))
IF $LENGTH(X)
Begin DoDot:1
+6 SET TFLG=0
SET DFLG=0
+7 IF $EXTRACT(X)="+"
SET TFLG=1
SET X=$EXTRACT(X,2,999)
SET $PIECE(FLD,U)=1
+8 IF $EXTRACT(X)="-"
SET DFLG=1
SET X=$EXTRACT(X,2,999)
+9 SET FNO=$PIECE(X,"|")
SET VAL=$PIECE(X,"|",2)
+10 IF '$DATA(^DD(FILE,+$GET(FNO),0))
IF $LENGTH(OUT)
SET OUT=OUT_"~"
SET OUT=OUT_FNO_"|Invalid field number"
QUIT
+11 ; 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
+12 ; SYNC DFLG AND VAL
IF VAL="@"
SET DFLG=1
+13 SET FLD(FNO)=VAL_U_TFLG_U_DFLG
+14 IF FNO=.01
IF TFLG
SET $PIECE(FLD,U,2)=1
+15 QUIT
End DoDot:1
+16 ; CAN'T DELETE A RECORD WITHOUT A VALID DAS
IF $PIECE($GET(FLD(.01)),U,3)
IF UFLG="A"
SET OUT="Record deletion cancelled. Missing DAS"
QUIT
+17 ; DELETION
IF $PIECE($GET(FLD(.01)),U,3)!($GET(GDFLG))
SET UFLG="D"
DELREC ; DELETE THE RECORD
IF UFLG="D"
DO DIK(OREF,DAS)
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
DINUM ; IF DINUM'D RECORD EXISTS, SWITCH TO MOD MODE
IF UFLG="A"
IF $GET(^DD(FILE,.01,0))["DINUM=X"
Begin DoDot:1
+1 SET %=FLD(.01)
+2 IF $EXTRACT(%)="`"
SET %=+$EXTRACT(%,2,99)
+3 ; OK TO ADD BRAND NEW RECORD BUT EXISTING RECORDS MUST BE EDITED
IF '$DATA(@CREF@(%,0))
QUIT
+4 KILL FLD(.01)
+5 SET DAS=%
SET UFLG="E"
+6 QUIT
End DoDot:1
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,DAS)
QUIT
+1 QUIT
+2 ;
DIK(DIK,DA) ; DELETE A RECORD
+1 ; PATCHED BY GIS 9/28/04 TO FIX PROBLEMS WITH SUBFILE DELETION
+2 ; CHECK FOR SUBFILE DELETION
IF '$GET(DAS(1))
GOTO DIK1
+3 NEW DA,IENS,I,DIK
+4 IF '$GET(FILE)
QUIT
+5 SET I=0
SET IENS=DAS_","
+6 MERGE DA=DAS
+7 FOR
SET I=$ORDER(DAS(I))
IF 'I
QUIT
SET IENS=IENS_DAS(I)_","
+8 SET DIK=$$ROOT^DILFD(FILE,IENS)
IF '$LENGTH(DIK)
QUIT
DIK1 DO ^DIK
+1 DO ^XBFMK
+2 QUIT
+3 ;
ADD(DIC) ; ADD A NEW ENTRY TO A FILE
+1 NEW X,Y,%,DA,DN,UP,SB,DNODE,ERR
+2 SET X=$PIECE($GET(FLD(.01)),U)
IF '$LENGTH(X)
SET OUT="Unable to add a new record"
QUIT
+3 ;S X=$$POINT(FILE,.01,X) ; ADD ACCENT GRAV IF NECESSARY
+4 ;S X=""""_X_"""" ; FORCE A NEW ENTRY
+5 SET DIC(0)="L"
+6 ; GET DIC("P") IF NECESSARY
IF $ORDER(DAS(0))
Begin DoDot:1
+7 ; CREATE THE DA ARRAY
SET %=0
FOR
SET %=$ORDER(DAS(%))
IF '%
QUIT
SET DA(%)=DAS(%)
+8 SET UP=$GET(^DD(FILE,0,"UP"))
IF 'UP
SET ERR=1
QUIT
+9 SET SB=$ORDER(^DD(UP,"SB",FILE,0))
IF 'SB
SET ERR=1
QUIT
+10 SET DIC("P")=$PIECE($GET(^DD(UP,SB,0)),U,2)
IF '$LENGTH(DIC("P"))
SET ERR=1
QUIT
+11 SET DN=DIC_"1,0)"
IF $DATA(DN)
QUIT
+12 ; CREATE THE DICTIONARY NODE
SET @DN=(U_DIC("P")_U_U)
+13 QUIT
End DoDot:1
IF $GET(ERR)
SET Y=-1
GOTO AFAIL
ADIC ;D ^DIC
+1 KILL DO,DD
DO FILE^DICN
AFAIL IF Y=-1
SET OUT="Unable to add a new record"
GOTO AX
+1 IF $ORDER(FLD(0))
DO EDIT(DIC,+Y)
QUIT
+2 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,SF,APCDALVR
+2 SET FNO=0
SET DR=""
SET APCDALVR=""
+3 IF UFLG="A"
SET OUT="OK 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 SET SF=$$WP(FILE,FNO)
+7 ; WORD PROCESSING FIELDS MANAGED SEPARATELY
IF SF
DO WORD(FILE,DA,FNO,CREF,VAL(FNO))
QUIT
+8 ; ADD ACCENT GRAV IF NECESSARY
SET VAL(FNO)=$$POINT(FILE,FNO,VAL(FNO))
+9 KILL ERR,RESULT
+10 IF VAL(FNO)="@"!(VAL(FNO)="")
SET RESULT="@"
+11 ; NO NEED TO EDIT THE .01 FIELD OF A RECORD THAT HAS JUST BEEN CREATED
IF FNO=.01
IF UFLG="A"
IF $EXTRACT(VAL(.01))="`"
SET VAL(.01)=$EXTRACT(VAL(.01),2,999)
QUIT
+12 ; CAN'T EDIT EXISTING PT AND VISIT FIELDS OF V FILES
IF FILE\1=9000010
IF $LENGTH($PIECE(FILE,".",2))=2
IF UFLG="E"
IF (FNO=.02!(FNO=.03))
QUIT
+13 IF FILE\1=9000010
IF $LENGTH($PIECE(FILE,".",2))=2
IF UFLG="A"
IF FNO=.03
IF VAL(.03)?1"`"1.N
SET %=+$EXTRACT(VAL(.03),2,99)
IF $DATA(^AUPNVSIT(%,0))
SET RESULT=%
GOTO E1
+14 ; THE VALIDITY CHECK FAILS - SO BYPASS THIS
IF FILE=9000011
IF FNO=.07
IF VAL(.07)?1.N
SET RESULT=VAL(.07)
GOTO E1
CHK IF VAL(FNO)'="@"
DO CHK^DIE(FILE,FNO,"",VAL(FNO),.RESULT,.ERR)
E1 IF RESULT=U
Begin DoDot:2
+1 SET MSG=$GET(ERR("DIERR",1,"TEXT",1),"Failed FileMan data validation")
+2 IF $LENGTH(OUT)
SET OUT=OUT_"~"
+3 IF TFLG!GTFLG
SET RFLG=1
SET OUT=FNO_"|"_MSG
QUIT
+4 SET OUT=OUT_FNO_"|"_MSG
+5 QUIT
End DoDot:2
QUIT
+6 SET VAL(FNO)=RESULT
+7 IF $LENGTH(DR)
SET DR=DR_";"
+8 ; DELETE THIS VALUE
IF RESULT="@"
SET DR=DR_FNO_"////@"
QUIT
+9 ; BUILD DR STRING
SET DR=DR_FNO_"////^S X=VAL("_FNO_")"
+10 QUIT
End DoDot:1
IF $GET(RFLG)
QUIT
+11 ; 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
+12 ; JUST IN CASE THIS IS A MILTIPLE, CREATE THE DA ARRAY
SET %=0
FOR
SET %=$ORDER(DAS(%))
IF '%
QUIT
SET DA(%)=DAS(%)
DIE ; 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
+1 ; FILE LOCKED. UNABLE TO UPDATE
SET OUT="Update cancelled. File locked"
+2 ; ROLLBACK THE NEW RECORD
IF $LENGTH(FLD)
IF UFLG="A"
DO DIK(DIE,DA)
EX ; CLEANUP
DO ^XBFMK
+1 QUIT
+2 ;
REF(FILE,DAS) ; GIVEN A FILE/SUBFILE NUMBER & DAS ARRAY, RETURN THE FM GLOBAL REFERENCE INFO: OREF|CREF|IENS
+1 NEW OREF,CREF,IENS,I,X
+2 SET IENS=$$IENS^DILF(.DAS)
IF '$LENGTH(IENS)
QUIT ""
+3 SET OREF=$$ROOT^DILFD(FILE,IENS)
IF '$LENGTH(OREF)
QUIT ""
+4 SET CREF=$$CREF^DILF(OREF)
IF '$LENGTH(CREF)
QUIT ""
+5 QUIT (OREF_"|"_CREF_"|"_IENS)
+6 ;
POINT(FILE,FNO,VAL) ; ADD ACCENT GRAV IF NECESSARY
+1 IF $EXTRACT(VAL)="`"
QUIT VAL
+2 IF $PIECE($GET(^DD(FILE,FNO,0)),U,2)["P"
IF VAL=+VAL
IF VAL\1=VAL
SET VAL="`"_VAL
+3 QUIT VAL
+4 ;
WP(FILE,FLD) ; RETURN THE SUBFILE NUMBER IF IT IS A WORD PROCESSING FIELD
+1 NEW SF,DTYPE
+2 SET SF=$PIECE($GET(^DD(+$GET(FILE),+$GET(FLD),0)),U,2)
IF 'SF
QUIT 0
+3 SET DTYPE=$PIECE($GET(^DD(SF,.01,0)),U,2)
+4 IF DTYPE["W"
QUIT SF
+5 QUIT 0
+6 ;
WORD(FILE,DA,FLD,CREF,VAL) ; SUFF TEXT ENTRY INTO THE WP MULTIPLE FIELD
+1 NEW SS,TOT,A,B,I
+2 SET SS=+$PIECE($GET(^DD(FILE,FLD,0)),U,4)
IF SS=""
QUIT
+3 ; DELETE THE WP RECORD: REMOVE DICTIONARY NODE AND DATA
IF VAL="@"!(VAL="")
KILL @CREF@(DA,SS)
QUIT
+4 SET TOT=0
+5 FOR
IF '$LENGTH(VAL)
QUIT
Begin DoDot:1
+6 ; PEEL OFF AN 80 CHARACTER DATA BLOCK FROM THE FRONT OF THE TEXT STRING
SET A=$EXTRACT(VAL,1,80)
SET VAL=$EXTRACT(VAL,81,999999)
+7 ; BUILD THE TEMP ARRAY
IF $LENGTH(A)
SET TOT=TOT+1
SET B(TOT)=A
+8 QUIT
End DoDot:1
+9 ; NOTHING TO STORE SO QUIT
IF '$DATA(B(1))
QUIT
+10 ; SET DICTIONARY NODE
SET @CREF@(DA,SS,0)="^^"_TOT_U_TOT_U_DT
+11 ; SET DATA NODES
FOR I=1:1:TOT
SET @CREF@(DA,SS,I,0)=B(I)
+12 QUIT
+13 ;
MERR ; MUMPS ERROR TRAP
+1 NEW ERR,X
+2 XECUTE ("S X=$"_"ZE")
+3 SET ERR="M ERROR: "_X
+4 SET OUT=ERR
+5 QUIT
+6 ;
