- 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
- 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
