IBDUTIL1 ;ALB/SS - GENERIC UTILITIES ;16-AUG-11
;;3.0;AUTOMATED INFO COLLECTION SYS;**63**;APR 24, 1997;Build 80
;
;
Q
;
;
;example
;adds text to Word Processing field
;IBDFILE - file #
;IBDIENS - "IEN,"
;IBDFLD - field #
;IBDFLG - flags "A" to append, "K" to lock and check locks
;IBDARR - arrays with data (see example below)
;returns:
; 1- success
; -1 -failure
;example:
; S IBDARR(1,0)="Line 1"
; S IBDARR(2,0)="Line 2"
; I $$UPDWD^IBD3P63(357.61,"175,1",".01","KA","IBDARR")=0 W "OKAY"
UPDWD(IBDFILE,IBDIENS,IBDFLD,IBDFLG,IBDARR) ;
N IBDERR
D WP^DIE(IBDFILE,IBDIENS,IBDFLD,IBDFLG,"IBDARR","IBDERR")
I $D(IBDERR("DIERR")) Q -1
Q 1
;/**
;Creates a new entry (or node for multiple with .01 field)
;
;IBDFILE - file/subfile number
;IBDIEN - ien of the parent file entry in which the new subfile entry will be inserted
;IBDZFDA - array with values for the fields
; format for IBDZFDA:
; IBDZFDA(.01)=value for #.01 field
; IBDZFDA(3)=value for #3 field
;IBDRECNO -(optional) specify IEN if you want specific value
; Note: "" then the system will assign the entry number itself.
;IBDFLGS - FLAGS parameter for UPDATE^DIE
;IBDLCKGL - fully specified global reference to lock
;IBDLCKTM - time out for LOCK, if LOCKTIME=0 then the function will not lock the file
;IBDNEWRE - optional, flag = if 1 then allow to create a new top level record
;
;output :
; positive number - record # created
; <=0 - failure
;
;example:
; S ZZ(.01)="ZZSS TEST",ZZ(.06)=1,ZZ(.09)=0 W $$INSREC^IBDUTIL1(357.6,"",.ZZ,"")
INSREC(IBDFILE,IBDIEN,IBDZFDA,IBDRECNO,IBDFLGS,IBDLCKGL,IBDLCKTM,IBDNEWRE) ;*/
I ('$G(IBDFILE)) Q "0^Invalid parameter"
I +$G(IBDNEWRE)=0 I $G(IBDRECNO)>0,'$G(IBDIEN) Q "0^Invalid parameter"
;I $G(IBDZFDA(.01))="" Q "0^Null"
N IBDSSI,IBDIENS,IBDERR,IBDFDA
N IBDLOCK S IBDLOCK=0
I '$G(IBDRECNO) N IBDRECNO S IBDRECNO=$G(IBDRECNO)
I IBDIEN'="" S IBDIENS="+1,"_IBDIEN_"," I $L(IBDRECNO)>0 S IBDSSI(1)=+IBDRECNO
I IBDIEN="" S IBDIENS="+1," I $L(IBDRECNO)>0 S IBDSSI(1)=+IBDRECNO
M IBDFDA(IBDFILE,IBDIENS)=IBDZFDA
I $L($G(IBDLCKGL)) L +@IBDLCKGL:(+$G(IBDLCKTM)) S IBDLOCK=$T I 'IBDLOCK Q -2 ;lock failure
D UPDATE^DIE($G(IBDFLGS),"IBDFDA","IBDSSI","IBDERR")
I IBDLOCK L -@IBDLCKGL
I $D(IBDERR) Q -1 ;D BMES^XPDUTL(IBDERR("DIERR",1,"TEXT",1))
;I $D(IBDERR) D BMES^XPDUTL($G(IBDERR("DIERR",1,"TEXT",1),"Update Error")) Q -1 ;D BMES^XPDUTL(IBDERR("DIERR",1,"TEXT",1))
Q +$G(IBDSSI(1))
;
;
;/**
;another version of the INSREC above - in case you need just one #.01 field to create a new record
;IBDVAL01 - .01 value for the new entry
;See INSREC for description of other parameters and return values
;
;Examples
;top level:
; W $$INSREC01^IBDUTIL1(366.14,"",IBDATE,"")
; W $$INSREC01^IBDUTIL1(357.6,"","ZZ TEST","")
;to create with the specific ien
; W $$INSREC01^IBDUTIL1(9002313.77,"",55555555,45555,,,,1)
;
;1st level multiple:
; subfile number = #366.141
; parent file #366.14 entry number = 345
; W $$INSREC01(366.141,345,"SUBMIT","")
; to create multiple entry with particular entry number = 23
; W $$INSREC01(366.141,345,"SUBMIT",23)
;
;2nd level multiple
;parent file #366.14 entry number = 234
;parent multiple entry number = 55
;create multiple entry INSURANCE
; W $$INSREC01(366.1412,"55,234","INS","")
; results in :
; ^IBCNR(366.14,234,1,55,5,0)=^366.1412PA^1^1
; ^IBCNR(366.14,234,1,55,5,1,0)=INS
; ^IBCNR(366.14,234,1,55,5,"B","INS",1)=
; (DD node for this multiple =5 )
INSREC01(IBDFILE,IBDIEN,IBDVAL01,IBDRECNO,IBDFLGS,IBDLCKGL,IBDLCKTM,IBDNEWRE) ;*/
I ('$G(IBDFILE)) Q "0^Invalid parameter"
I +$G(IBDNEWRE)=0 I $G(IBDRECNO)>0,'$G(IBDIEN) Q "0^Invalid parameter"
N IBDFDAZ
S IBDFDAZ(.01)=IBDVAL01
Q $$INSREC(IBDFILE,IBDIEN,.IBDFDAZ,IBDRECNO,$G(IBDFLGS),$G(IBDLCKGL),$G(IBDLCKTM),$G(IBDNEWRE))
;
;
;populate multiple fields at once
;Input:
;IBDFILEN file number
;IBDIEN ien string
;IBDVALAR new values (internal format) in the format
; IBDVALAR(IBDFLDNO)=values
; where IBDFLDNO - the field number
; example:
; IBDVALAR(.01)=value for #.01 field
; IBDVALAR(3)=value for #3 field
;IBDFLAG - null (for internal format) or "E" (for external format with validation)
;Output:
;0 if failure
;1 if success
; example: see $$UPD35703^IBDUTICD
MULTFLDS(IBDFILEN,IBDIEN,IBDVALAR,IBDFLAG) ;
I '$G(IBDFILEN) Q "0^Invalid parameter"
I '$G(IBDIEN) Q "0^Invalid parameter"
N IBDIENS,IBDFDA,IBDERARY
S IBDIENS=IBDIEN_","
M IBDFDA(IBDFILEN,IBDIENS)=IBDVALAR
D FILE^DIE($G(IBDFLAG),"IBDFDA","IBDERARY")
I $D(IBDERARY) Q 0
Q 1
;
;populate a single database field
;Input:
;IBDFILEN file number
;IBDFLDNO field number
;IBDIEN ien string
;IBDVAL new value to file (internal format)
;IBDFLAG - null (for internal format) or "E" (for external format with validation)
;Output:
;0^IBDVAL^error if failure
;1^IBDVAL if success
SINGLFLD(IBDFILEN,IBDFLDNO,IBDIEN,IBDVAL,IBDFLAG) ;
I '$G(IBDFILEN) Q "0^Invalid parameter"
I '$G(IBDFLDNO) Q "0^Invalid parameter"
I '$G(IBDIEN) Q "0^Invalid parameter"
I $G(IBDVAL)="" Q "0^Null"
N IBDIENS,IBDFDA,IBDERARY
S IBDIENS=IBDIEN_","
S IBDFDA(IBDFILEN,IBDIENS,IBDFLDNO)=IBDVAL
D FILE^DIE($G(IBDFLAG),"IBDFDA","IBDERARY")
I $D(IBDERARY) Q "0^"_IBDVAL_"^"_IBDERARY("DIERR",1,"TEXT",1)
Q "1^"_IBDVAL
;
;/**
;enter free text like comments
;IBDPROM -prompt string
;IBDMXLEN -maxlen
FREETEXT(IBDPROM,IBDMXLEN) ;*/
N DIR,DTOUT,DUOUT,IBDQ
I '$D(IBDPROM) S IBDPROM="Enter a text "
I '$D(IBDMXLEN) S IBDMXLEN=40
S DIR(0)="FO^0:250"
S DIR("A")=IBDPROM
S DIR("?",1)="This response must have no more than "_IBDMXLEN_" characters"
S DIR("?")="and must not contain embedded up arrow."
S IBDQ=0
F D Q:+IBDQ'=0
. D ^DIR
. I $D(DUOUT)!($D(DTOUT)) S IBDQ=-1 Q
. I $L(Y)'>IBDMXLEN S IBDQ=1 Q
. W !!,"This response must have no more than "_IBDMXLEN_" characters"
. W !,"and must not contain embedded uparrow.",!
. S DIR("B")=$E(Y,1,IBDMXLEN)
Q:IBDQ<0 "^"
Q Y
;
;Standard Yes/No PROMPT:
;
;Parameters:
; IBDPROM = Text to be displayed before read
; IBDDFLT = YES, NO or <Null>
; IBDOPT = 1 - Answer optional 0 - Answer required
; IBDTMOUT = Number of seconds
;
;Returns:
; <null> = No response <^> - Up-arrow entered
; <-1> = Timeout occurred <^^> - Two up-arrows entered
; <0> = No <1> - Yes
;
YESNO(IBDPROM,IBDDFLT,IBDOPT,IBDTMOUT) ;EP
;
N DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
;
Q:$G(IBDPROM)="" ""
;
S $P(DIR(0),"^",1)="Y"_$S(IBDOPT=1:"O",1:"")
S DIR("A")=IBDPROM
S:$G(IBDDFLT)'="" DIR("B")=IBDDFLT
S:+$G(IBDTMOUT)>0 DIR("T")=IBDTMOUT
D ^DIR
Q $S($G(DTOUT)=1:-1,$G(DIROUT)=1:"^^",$G(DUOUT)=1:"^",1:Y)
;
;
;fill fields
;Input:
;IBDFILNO file number
;IBDFIELD field number
;IBDIEN ien string
;IBDNEWVL new value to file (internal format)
;Output:
;0^ IBDNEWVL^error if failure
;1^ IBDNEWVL if success
;Example:
; W $$FILLFLDS^IBDUTIL1(357.1,.01,227,"AA SHAVKAT DIAGNOSIS")
; 1^AA SHAVKAT DIAGNOSIS
FILLFLDS(IBDFILNO,IBDFIELD,IBDIEN,IBDNEWVL) ;
I '$G(IBDFILNO) Q "0^Invalid parameter"
I '$G(IBDFIELD) Q "0^Invalid parameter"
I '$G(IBDIEN) Q "0^Invalid parameter"
I $G(IBDNEWVL)="" Q "0^Null"
N IBDIENS,IBDFDA,IBDERARY
S IBDIENS=IBDIEN_","
S IBDFDA(IBDFILNO,IBDIENS,IBDFIELD)=IBDNEWVL
D FILE^DIE("","IBDFDA","IBDERARY")
I $D(IBDERARY) Q "0^"_IBDNEWVL_"^"_IBDERARY("DIERR",1,"TEXT",1)
Q "1^"_IBDNEWVL
;
;IBDUTIL1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBDUTIL1 7650 printed Nov 22, 2024@18:04:13 Page 2
IBDUTIL1 ;ALB/SS - GENERIC UTILITIES ;16-AUG-11
+1 ;;3.0;AUTOMATED INFO COLLECTION SYS;**63**;APR 24, 1997;Build 80
+2 ;
+3 ;
+4 QUIT
+5 ;
+6 ;
+7 ;example
+8 ;adds text to Word Processing field
+9 ;IBDFILE - file #
+10 ;IBDIENS - "IEN,"
+11 ;IBDFLD - field #
+12 ;IBDFLG - flags "A" to append, "K" to lock and check locks
+13 ;IBDARR - arrays with data (see example below)
+14 ;returns:
+15 ; 1- success
+16 ; -1 -failure
+17 ;example:
+18 ; S IBDARR(1,0)="Line 1"
+19 ; S IBDARR(2,0)="Line 2"
+20 ; I $$UPDWD^IBD3P63(357.61,"175,1",".01","KA","IBDARR")=0 W "OKAY"
UPDWD(IBDFILE,IBDIENS,IBDFLD,IBDFLG,IBDARR) ;
+1 NEW IBDERR
+2 DO WP^DIE(IBDFILE,IBDIENS,IBDFLD,IBDFLG,"IBDARR","IBDERR")
+3 IF $DATA(IBDERR("DIERR"))
QUIT -1
+4 QUIT 1
+5 ;/**
+6 ;Creates a new entry (or node for multiple with .01 field)
+7 ;
+8 ;IBDFILE - file/subfile number
+9 ;IBDIEN - ien of the parent file entry in which the new subfile entry will be inserted
+10 ;IBDZFDA - array with values for the fields
+11 ; format for IBDZFDA:
+12 ; IBDZFDA(.01)=value for #.01 field
+13 ; IBDZFDA(3)=value for #3 field
+14 ;IBDRECNO -(optional) specify IEN if you want specific value
+15 ; Note: "" then the system will assign the entry number itself.
+16 ;IBDFLGS - FLAGS parameter for UPDATE^DIE
+17 ;IBDLCKGL - fully specified global reference to lock
+18 ;IBDLCKTM - time out for LOCK, if LOCKTIME=0 then the function will not lock the file
+19 ;IBDNEWRE - optional, flag = if 1 then allow to create a new top level record
+20 ;
+21 ;output :
+22 ; positive number - record # created
+23 ; <=0 - failure
+24 ;
+25 ;example:
+26 ; S ZZ(.01)="ZZSS TEST",ZZ(.06)=1,ZZ(.09)=0 W $$INSREC^IBDUTIL1(357.6,"",.ZZ,"")
INSREC(IBDFILE,IBDIEN,IBDZFDA,IBDRECNO,IBDFLGS,IBDLCKGL,IBDLCKTM,IBDNEWRE) ;*/
+1 IF ('$GET(IBDFILE))
QUIT "0^Invalid parameter"
+2 IF +$GET(IBDNEWRE)=0
IF $GET(IBDRECNO)>0
IF '$GET(IBDIEN)
QUIT "0^Invalid parameter"
+3 ;I $G(IBDZFDA(.01))="" Q "0^Null"
+4 NEW IBDSSI,IBDIENS,IBDERR,IBDFDA
+5 NEW IBDLOCK
SET IBDLOCK=0
+6 IF '$GET(IBDRECNO)
NEW IBDRECNO
SET IBDRECNO=$GET(IBDRECNO)
+7 IF IBDIEN'=""
SET IBDIENS="+1,"_IBDIEN_","
IF $LENGTH(IBDRECNO)>0
SET IBDSSI(1)=+IBDRECNO
+8 IF IBDIEN=""
SET IBDIENS="+1,"
IF $LENGTH(IBDRECNO)>0
SET IBDSSI(1)=+IBDRECNO
+9 MERGE IBDFDA(IBDFILE,IBDIENS)=IBDZFDA
+10 ;lock failure
IF $LENGTH($GET(IBDLCKGL))
LOCK +@IBDLCKGL:(+$GET(IBDLCKTM))
SET IBDLOCK=$TEST
IF 'IBDLOCK
QUIT -2
+11 DO UPDATE^DIE($GET(IBDFLGS),"IBDFDA","IBDSSI","IBDERR")
+12 IF IBDLOCK
LOCK -@IBDLCKGL
+13 ;D BMES^XPDUTL(IBDERR("DIERR",1,"TEXT",1))
IF $DATA(IBDERR)
QUIT -1
+14 ;I $D(IBDERR) D BMES^XPDUTL($G(IBDERR("DIERR",1,"TEXT",1),"Update Error")) Q -1 ;D BMES^XPDUTL(IBDERR("DIERR",1,"TEXT",1))
+15 QUIT +$GET(IBDSSI(1))
+16 ;
+17 ;
+18 ;/**
+19 ;another version of the INSREC above - in case you need just one #.01 field to create a new record
+20 ;IBDVAL01 - .01 value for the new entry
+21 ;See INSREC for description of other parameters and return values
+22 ;
+23 ;Examples
+24 ;top level:
+25 ; W $$INSREC01^IBDUTIL1(366.14,"",IBDATE,"")
+26 ; W $$INSREC01^IBDUTIL1(357.6,"","ZZ TEST","")
+27 ;to create with the specific ien
+28 ; W $$INSREC01^IBDUTIL1(9002313.77,"",55555555,45555,,,,1)
+29 ;
+30 ;1st level multiple:
+31 ; subfile number = #366.141
+32 ; parent file #366.14 entry number = 345
+33 ; W $$INSREC01(366.141,345,"SUBMIT","")
+34 ; to create multiple entry with particular entry number = 23
+35 ; W $$INSREC01(366.141,345,"SUBMIT",23)
+36 ;
+37 ;2nd level multiple
+38 ;parent file #366.14 entry number = 234
+39 ;parent multiple entry number = 55
+40 ;create multiple entry INSURANCE
+41 ; W $$INSREC01(366.1412,"55,234","INS","")
+42 ; results in :
+43 ; ^IBCNR(366.14,234,1,55,5,0)=^366.1412PA^1^1
+44 ; ^IBCNR(366.14,234,1,55,5,1,0)=INS
+45 ; ^IBCNR(366.14,234,1,55,5,"B","INS",1)=
+46 ; (DD node for this multiple =5 )
INSREC01(IBDFILE,IBDIEN,IBDVAL01,IBDRECNO,IBDFLGS,IBDLCKGL,IBDLCKTM,IBDNEWRE) ;*/
+1 IF ('$GET(IBDFILE))
QUIT "0^Invalid parameter"
+2 IF +$GET(IBDNEWRE)=0
IF $GET(IBDRECNO)>0
IF '$GET(IBDIEN)
QUIT "0^Invalid parameter"
+3 NEW IBDFDAZ
+4 SET IBDFDAZ(.01)=IBDVAL01
+5 QUIT $$INSREC(IBDFILE,IBDIEN,.IBDFDAZ,IBDRECNO,$GET(IBDFLGS),$GET(IBDLCKGL),$GET(IBDLCKTM),$GET(IBDNEWRE))
+6 ;
+7 ;
+8 ;populate multiple fields at once
+9 ;Input:
+10 ;IBDFILEN file number
+11 ;IBDIEN ien string
+12 ;IBDVALAR new values (internal format) in the format
+13 ; IBDVALAR(IBDFLDNO)=values
+14 ; where IBDFLDNO - the field number
+15 ; example:
+16 ; IBDVALAR(.01)=value for #.01 field
+17 ; IBDVALAR(3)=value for #3 field
+18 ;IBDFLAG - null (for internal format) or "E" (for external format with validation)
+19 ;Output:
+20 ;0 if failure
+21 ;1 if success
+22 ; example: see $$UPD35703^IBDUTICD
MULTFLDS(IBDFILEN,IBDIEN,IBDVALAR,IBDFLAG) ;
+1 IF '$GET(IBDFILEN)
QUIT "0^Invalid parameter"
+2 IF '$GET(IBDIEN)
QUIT "0^Invalid parameter"
+3 NEW IBDIENS,IBDFDA,IBDERARY
+4 SET IBDIENS=IBDIEN_","
+5 MERGE IBDFDA(IBDFILEN,IBDIENS)=IBDVALAR
+6 DO FILE^DIE($GET(IBDFLAG),"IBDFDA","IBDERARY")
+7 IF $DATA(IBDERARY)
QUIT 0
+8 QUIT 1
+9 ;
+10 ;populate a single database field
+11 ;Input:
+12 ;IBDFILEN file number
+13 ;IBDFLDNO field number
+14 ;IBDIEN ien string
+15 ;IBDVAL new value to file (internal format)
+16 ;IBDFLAG - null (for internal format) or "E" (for external format with validation)
+17 ;Output:
+18 ;0^IBDVAL^error if failure
+19 ;1^IBDVAL if success
SINGLFLD(IBDFILEN,IBDFLDNO,IBDIEN,IBDVAL,IBDFLAG) ;
+1 IF '$GET(IBDFILEN)
QUIT "0^Invalid parameter"
+2 IF '$GET(IBDFLDNO)
QUIT "0^Invalid parameter"
+3 IF '$GET(IBDIEN)
QUIT "0^Invalid parameter"
+4 IF $GET(IBDVAL)=""
QUIT "0^Null"
+5 NEW IBDIENS,IBDFDA,IBDERARY
+6 SET IBDIENS=IBDIEN_","
+7 SET IBDFDA(IBDFILEN,IBDIENS,IBDFLDNO)=IBDVAL
+8 DO FILE^DIE($GET(IBDFLAG),"IBDFDA","IBDERARY")
+9 IF $DATA(IBDERARY)
QUIT "0^"_IBDVAL_"^"_IBDERARY("DIERR",1,"TEXT",1)
+10 QUIT "1^"_IBDVAL
+11 ;
+12 ;/**
+13 ;enter free text like comments
+14 ;IBDPROM -prompt string
+15 ;IBDMXLEN -maxlen
FREETEXT(IBDPROM,IBDMXLEN) ;*/
+1 NEW DIR,DTOUT,DUOUT,IBDQ
+2 IF '$DATA(IBDPROM)
SET IBDPROM="Enter a text "
+3 IF '$DATA(IBDMXLEN)
SET IBDMXLEN=40
+4 SET DIR(0)="FO^0:250"
+5 SET DIR("A")=IBDPROM
+6 SET DIR("?",1)="This response must have no more than "_IBDMXLEN_" characters"
+7 SET DIR("?")="and must not contain embedded up arrow."
+8 SET IBDQ=0
+9 FOR
Begin DoDot:1
+10 DO ^DIR
+11 IF $DATA(DUOUT)!($DATA(DTOUT))
SET IBDQ=-1
QUIT
+12 IF $LENGTH(Y)'>IBDMXLEN
SET IBDQ=1
QUIT
+13 WRITE !!,"This response must have no more than "_IBDMXLEN_" characters"
+14 WRITE !,"and must not contain embedded uparrow.",!
+15 SET DIR("B")=$EXTRACT(Y,1,IBDMXLEN)
End DoDot:1
if +IBDQ'=0
QUIT
+16 if IBDQ<0
QUIT "^"
+17 QUIT Y
+18 ;
+19 ;Standard Yes/No PROMPT:
+20 ;
+21 ;Parameters:
+22 ; IBDPROM = Text to be displayed before read
+23 ; IBDDFLT = YES, NO or <Null>
+24 ; IBDOPT = 1 - Answer optional 0 - Answer required
+25 ; IBDTMOUT = Number of seconds
+26 ;
+27 ;Returns:
+28 ; <null> = No response <^> - Up-arrow entered
+29 ; <-1> = Timeout occurred <^^> - Two up-arrows entered
+30 ; <0> = No <1> - Yes
+31 ;
YESNO(IBDPROM,IBDDFLT,IBDOPT,IBDTMOUT) ;EP
+1 ;
+2 NEW DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
+3 ;
+4 if $GET(IBDPROM)=""
QUIT ""
+5 ;
+6 SET $PIECE(DIR(0),"^",1)="Y"_$SELECT(IBDOPT=1:"O",1:"")
+7 SET DIR("A")=IBDPROM
+8 if $GET(IBDDFLT)'=""
SET DIR("B")=IBDDFLT
+9 if +$GET(IBDTMOUT)>0
SET DIR("T")=IBDTMOUT
+10 DO ^DIR
+11 QUIT $SELECT($GET(DTOUT)=1:-1,$GET(DIROUT)=1:"^^",$GET(DUOUT)=1:"^",1:Y)
+12 ;
+13 ;
+14 ;fill fields
+15 ;Input:
+16 ;IBDFILNO file number
+17 ;IBDFIELD field number
+18 ;IBDIEN ien string
+19 ;IBDNEWVL new value to file (internal format)
+20 ;Output:
+21 ;0^ IBDNEWVL^error if failure
+22 ;1^ IBDNEWVL if success
+23 ;Example:
+24 ; W $$FILLFLDS^IBDUTIL1(357.1,.01,227,"AA SHAVKAT DIAGNOSIS")
+25 ; 1^AA SHAVKAT DIAGNOSIS
FILLFLDS(IBDFILNO,IBDFIELD,IBDIEN,IBDNEWVL) ;
+1 IF '$GET(IBDFILNO)
QUIT "0^Invalid parameter"
+2 IF '$GET(IBDFIELD)
QUIT "0^Invalid parameter"
+3 IF '$GET(IBDIEN)
QUIT "0^Invalid parameter"
+4 IF $GET(IBDNEWVL)=""
QUIT "0^Null"
+5 NEW IBDIENS,IBDFDA,IBDERARY
+6 SET IBDIENS=IBDIEN_","
+7 SET IBDFDA(IBDFILNO,IBDIENS,IBDFIELD)=IBDNEWVL
+8 DO FILE^DIE("","IBDFDA","IBDERARY")
+9 IF $DATA(IBDERARY)
QUIT "0^"_IBDNEWVL_"^"_IBDERARY("DIERR",1,"TEXT",1)
+10 QUIT "1^"_IBDNEWVL
+11 ;
+12 ;IBDUTIL1
