MCDBSAVE ;WISC/DCB-save and load util. ;7/18/96 14:08
;;2.3;Medicine;;09/13/1996
Q
;{See MCDBELM for Field values}
SAVE(FILE,REC,FIELDS,EXC,DATA,TYPE,USER,ERROR) ;SAVE some fields
N TEMP,RECS,FLDS,FILES
S ERROR=""
D RTNELM^MCDBELM(FILE,REC,FIELDS,.EXC,DATA,TYPE,USER,.TEMP,.ERROR)
D:ERROR="" SETREC(.TEMP,.ERROR)
S:ERROR="" ERROR=$$CHECK(.TEMP)
Q
SETREC(TEMP,ERROR) ;Save the record
N DIE,DR,DA,DIC,DTOUT,Y,DIROUT,DUOUT,DTOUT,DIRUT,DIROUT
S ERROR=""
I '$D(TEMP) S ERROR=" 0.0 - Require array not define" Q
S DR=$$RTNDR^MCDBELM(.TEMP,1) I DR="" S ERROR=" Nothing to save" Q
S DIE=TEMP("DIC") I $E(DIE,1)=" " S ERROR=DIE Q
D RTNDA^MCDBELM(.TEMP,.DA,.ERROR) Q:ERROR'=""
D ^DIE
I '$D(DA) S ERROR=" inf - Record was deleted" Q
I $D(DTOUT) S ERROR=" inf - User timeout" Q
I $D(Y)'=0&(TEMP("USER")=2) S ERROR=" inf - User Up-arrow out" Q
Q
CHECK(TEMP) ;Checks the field values
N ERROR,XTOTAL,DIC,DR,DA,DIQ,XPLACE,XHOLD
N XFILE,XFLD,XSTR,XINT,XEXT S ERROR=""
Q:TEMP("USER")'=0 ""
S DR="",XTOTAL=$$TOTAL^MCDBELM(.TEMP),DIC=TEMP("DIC") Q:$E(DIC,1)=" " DIE
S DR=$$RTNDR^MCDBELM(.TEMP) Q:ERROR'=""
D RTNDA^MCDBELM(.TEMP,.DA,.ERROR) Q:ERROR'=""
S DIQ(0)="IE",DIQ="HOLD("
D EN^DIQ1
S XFILE=$P(TEMP(XTOTAL),U,1),XPLACE=DIQ_XFILE_","_DA_",",XHOLD=""
F S XHOLD=+$O(TEMP("FLD",XHOLD)) Q:XHOLD=0!(ERROR'="") D
.S XFLD=XHOLD,XSTR=TEMP("FLD",XHOLD)
.S XSTR=$S(XSTR="@":"",1:XSTR)
.S XINT=$G(@(XPLACE_XHOLD_",""I"")")),XEXT=$G(@(XPLACE_XHOLD_",""E"")"))
.I (XINT'=XSTR),(XEXT'=XSTR) S ERROR=" 6.1 - Data error for field "_XHOLD,ERROR(1)="USE: "_XSTR,ERROR(2)="EXT: "_XEXT,ERROR(3)="INT: "_XINT
Q ERROR
LOAD(FILE,REC,FIELDS,EXC,TYPE,TEMP,ERROR) ;LOAD some fields
D RTNELM^MCDBELM(FILE,REC,FIELDS,.EXC,"",TYPE,1,.TEMP,.ERROR)
D:ERROR="" GETDATA(.TEMP,.ERROR)
Q
GETDATA(TEMP,ERROR) ;RETRIEVE THE DATA THAT WAS SAVED
N X,XTOTAL,DIC,DR,DA,DIQ,XPLACE,XHOLD
N XFILE,XFLD,XSTR,XINT,XEXT,XTYP S ERROR=""
I '$D(TEMP) S ERROR=" 0.0 - Require array not define" Q
S DR="",XTOTAL=$$TOTAL^MCDBELM(.TEMP),DIC=TEMP("DIC")
I $E(DIC,1)=" " S ERROR=DIE Q
S DR=$$RTNDR^MCDBELM(.TEMP) Q:ERROR'=""
D RTNDA^MCDBELM(.TEMP,.DA,.ERROR) Q:ERROR'=""
S DIQ(0)="IE",DIQ="XHOLD("
D EN^DIQ1
S XFILE=$P(TEMP(XTOTAL),U,1),XPLACE=DIQ_XFILE_","_DA_",",XHOLD=""
F S XHOLD=+$O(TEMP("TYP",XHOLD)) Q:XHOLD=0!(ERROR'="") D
.S XTYP=TEMP("TYP",XHOLD) S XTYP=$TR(XTYP,"ei","EI")
.S XINT=$G(@(XPLACE_XHOLD_",""I"")")),XEXT=$G(@(XPLACE_XHOLD_",""E"")"))
.I $G(TEMP("EXC",XHOLD))'="" S X=XINT X TEMP("EXC",XHOLD) S:$G(X)'=XINT (XEXT,XINT)=X
.S TEMP("FLD",XHOLD)=$S(XTYP="I":XINT,XTYP="E":XEXT,XINT=XEXT:XINT,1:XINT_U_XEXT)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMCDBSAVE 2675 printed Dec 13, 2024@02:14:48 Page 2
MCDBSAVE ;WISC/DCB-save and load util. ;7/18/96 14:08
+1 ;;2.3;Medicine;;09/13/1996
+2 QUIT
+3 ;{See MCDBELM for Field values}
SAVE(FILE,REC,FIELDS,EXC,DATA,TYPE,USER,ERROR) ;SAVE some fields
+1 NEW TEMP,RECS,FLDS,FILES
+2 SET ERROR=""
+3 DO RTNELM^MCDBELM(FILE,REC,FIELDS,.EXC,DATA,TYPE,USER,.TEMP,.ERROR)
+4 if ERROR=""
DO SETREC(.TEMP,.ERROR)
+5 if ERROR=""
SET ERROR=$$CHECK(.TEMP)
+6 QUIT
SETREC(TEMP,ERROR) ;Save the record
+1 NEW DIE,DR,DA,DIC,DTOUT,Y,DIROUT,DUOUT,DTOUT,DIRUT,DIROUT
+2 SET ERROR=""
+3 IF '$DATA(TEMP)
SET ERROR=" 0.0 - Require array not define"
QUIT
+4 SET DR=$$RTNDR^MCDBELM(.TEMP,1)
IF DR=""
SET ERROR=" Nothing to save"
QUIT
+5 SET DIE=TEMP("DIC")
IF $EXTRACT(DIE,1)=" "
SET ERROR=DIE
QUIT
+6 DO RTNDA^MCDBELM(.TEMP,.DA,.ERROR)
if ERROR'=""
QUIT
+7 DO ^DIE
+8 IF '$DATA(DA)
SET ERROR=" inf - Record was deleted"
QUIT
+9 IF $DATA(DTOUT)
SET ERROR=" inf - User timeout"
QUIT
+10 IF $DATA(Y)'=0&(TEMP("USER")=2)
SET ERROR=" inf - User Up-arrow out"
QUIT
+11 QUIT
CHECK(TEMP) ;Checks the field values
+1 NEW ERROR,XTOTAL,DIC,DR,DA,DIQ,XPLACE,XHOLD
+2 NEW XFILE,XFLD,XSTR,XINT,XEXT
SET ERROR=""
+3 if TEMP("USER")'=0
QUIT ""
+4 SET DR=""
SET XTOTAL=$$TOTAL^MCDBELM(.TEMP)
SET DIC=TEMP("DIC")
if $EXTRACT(DIC,1)=" "
QUIT DIE
+5 SET DR=$$RTNDR^MCDBELM(.TEMP)
if ERROR'=""
QUIT
+6 DO RTNDA^MCDBELM(.TEMP,.DA,.ERROR)
if ERROR'=""
QUIT
+7 SET DIQ(0)="IE"
SET DIQ="HOLD("
+8 DO EN^DIQ1
+9 SET XFILE=$PIECE(TEMP(XTOTAL),U,1)
SET XPLACE=DIQ_XFILE_","_DA_","
SET XHOLD=""
+10 FOR
SET XHOLD=+$ORDER(TEMP("FLD",XHOLD))
if XHOLD=0!(ERROR'="")
QUIT
Begin DoDot:1
+11 SET XFLD=XHOLD
SET XSTR=TEMP("FLD",XHOLD)
+12 SET XSTR=$SELECT(XSTR="@":"",1:XSTR)
+13 SET XINT=$GET(@(XPLACE_XHOLD_",""I"")"))
SET XEXT=$GET(@(XPLACE_XHOLD_",""E"")"))
+14 IF (XINT'=XSTR)
IF (XEXT'=XSTR)
SET ERROR=" 6.1 - Data error for field "_XHOLD
SET ERROR(1)="USE: "_XSTR
SET ERROR(2)="EXT: "_XEXT
SET ERROR(3)="INT: "_XINT
End DoDot:1
+15 QUIT ERROR
LOAD(FILE,REC,FIELDS,EXC,TYPE,TEMP,ERROR) ;LOAD some fields
+1 DO RTNELM^MCDBELM(FILE,REC,FIELDS,.EXC,"",TYPE,1,.TEMP,.ERROR)
+2 if ERROR=""
DO GETDATA(.TEMP,.ERROR)
+3 QUIT
GETDATA(TEMP,ERROR) ;RETRIEVE THE DATA THAT WAS SAVED
+1 NEW X,XTOTAL,DIC,DR,DA,DIQ,XPLACE,XHOLD
+2 NEW XFILE,XFLD,XSTR,XINT,XEXT,XTYP
SET ERROR=""
+3 IF '$DATA(TEMP)
SET ERROR=" 0.0 - Require array not define"
QUIT
+4 SET DR=""
SET XTOTAL=$$TOTAL^MCDBELM(.TEMP)
SET DIC=TEMP("DIC")
+5 IF $EXTRACT(DIC,1)=" "
SET ERROR=DIE
QUIT
+6 SET DR=$$RTNDR^MCDBELM(.TEMP)
if ERROR'=""
QUIT
+7 DO RTNDA^MCDBELM(.TEMP,.DA,.ERROR)
if ERROR'=""
QUIT
+8 SET DIQ(0)="IE"
SET DIQ="XHOLD("
+9 DO EN^DIQ1
+10 SET XFILE=$PIECE(TEMP(XTOTAL),U,1)
SET XPLACE=DIQ_XFILE_","_DA_","
SET XHOLD=""
+11 FOR
SET XHOLD=+$ORDER(TEMP("TYP",XHOLD))
if XHOLD=0!(ERROR'="")
QUIT
Begin DoDot:1
+12 SET XTYP=TEMP("TYP",XHOLD)
SET XTYP=$TRANSLATE(XTYP,"ei","EI")
+13 SET XINT=$GET(@(XPLACE_XHOLD_",""I"")"))
SET XEXT=$GET(@(XPLACE_XHOLD_",""E"")"))
+14 IF $GET(TEMP("EXC",XHOLD))'=""
SET X=XINT
XECUTE TEMP("EXC",XHOLD)
if $GET(X)'=XINT
SET (XEXT,XINT)=X
+15 SET TEMP("FLD",XHOLD)=$SELECT(XTYP="I":XINT,XTYP="E":XEXT,XINT=XEXT:XINT,1:XINT_U_XEXT)
End DoDot:1
+16 QUIT
