BIFMAN ;IHS/CMI/MWR - FILEMAN CALLS; MAY 10, 2010
;;8.5;IMMUNIZATION;;SEP 01,2011
;;* MICHAEL REMILLARD, DDS * CIMARRON MEDICAL INFORMATICS, FOR IHS *
;; CALLS TO FILEMAN WITH PRE- AND POST-CALL VARIABLE SETTING.
;
;
;----------
DIC(DIC,DIC0,BIY,DICA,DICB,DICS,BIX,BIPOP,DICDR) ;EP
;---> CALL TO ^DIC - File lookup and/or add new entry.
;---> Parameters:
; 1 - DIC=DIC (req)
; 2 - DIC0=DIC(0) (req)
; 3 - BIY (ret) Equal to Y from call to ^DIC.
; 4 - DICA=DIC("A") (opt) Prompt
; 5 - DICB=DIC("B") (opt) DEFAULT
; 6 - DICS=DIC("S") (opt) Screen
; 7 - BIX (opt) Equal to X if DIC(0)'["A".
; 8 - BIPOP (opt) BIPOP=1 if DTOUT or DUOUT
; 9 - DICDR=DIC("DR") (opt) To specify fields to be asked when
; adding a new entry.
;
;---> Example: D DIC^BIFMAN(9002086,"QEMAL",.Y," Select PATIENT: ")
; To stuff an entry:
; D DIC^BIFMAN(9002086,"QEML",.Y,,,,"NewEntry")
;
N X,Y
S:$G(BIX)]"" X=BIX
I $G(DIC)']""!($G(DIC0)']"") S BIPOP=1 Q
S BIPOP=0 S:DIC DLAYGO=$P(DIC,".")
S DIC(0)=DIC0
S:$G(DICA)]"" DIC("A")=DICA
S:$G(DICB)]"" DIC("B")=DICB
S:$G(DICDR)]"" DIC("DR")=DICDR
S:$G(DICS)]"" DIC("S")=DICS
D ^DIC
S BIY=Y
S:($D(DTOUT))!($D(DUOUT)) BIPOP=1
D DKILLS
Q
;
;
;----------
UPDATE(BIFN,BIIEN,BIFLD,BIERR,BIEXT) ;EP
;---> CALL TO UPDATE^DIE - To *ADD* new entry or subentry to a file.
;---> Parameters:
; 1 - BIFN (req) File Number.
; 2 - BIIEN (opt) IENS Array setting Seq Number=desire IEN in global.
; 3 - BIFLD (req) Array of BIFLD(Field#)=Value, esp. need a .01 node,
; may need other required fields.
; 4 - BIERR (ret) Text of error, if any.
; 5 - BIEXT (opt) If BIEXT="E", tell UPDATE^DIE values are External.
;
;---> Example: N BIERR,BIFLD,BIIEN
; S BIIEN(1)=777 (This is to S DINUM=X; specify IEN in global)
; S BIFLD(.01)=777
; S BIFLD(.02)="This is a test of UPDATE~DIE."
; D UPDATE^BIFMAN(9002084.33,.BIIEN,.BIFLD,.BIERR)
; I $G(BIERR)]"" W !!?3,BIERR D DIRZ^BIUTL3()
; OR
; NOTE!: 2nd Parameter, BIIEN, is optional;
; But you must set BIFLD(.01)=something.
; N BIERR,BIFLD
; S BIFLD(.01)=BIDFN,BIFLD(.02)=BIPTR,BIFLD(.03)=BIREAS
; D UPDATE^BIFMAN(9002084.11,,.BIFLD,.BIERR)
;
N BIFDA,BIMSG,BISEQN
;
;---Check for valid File Number and Data Dictionary.
I '$G(BIFN) D ERRCD^BIUTL2(671,.BIERR) Q
I '$D(^DD($G(BIFN),0)) D ERRCD^BIUTL2(671,.BIERR) Q
;
;---> Set BISEQN is Sequence Number #1 set to ADD new top level entry.
S BISEQN="+1,"
;---> Process External/Internal Flag value.
S BIEXT=$S($G(BIEXT)=1:"E",1:"")
;
;---> Create FDA.
N N S N=0
F S N=$O(BIFLD(N)) Q:'N D
.S BIFDA(BIFN,BISEQN,N)=BIFLD(N)
;
D UPDATE^DIE(BIEXT,"BIFDA","BIIEN","BIMSG")
;
S BIERR=$G(BIMSG("DIERR",1,"TEXT",1))
I BIERR'="" S BIERR=BIERR_" (software error) #674"
D DKILLS
Q
;
;
;----------
DDS(DDSFILE,DR,DA,DDSPARM,DDSSAVE,BIPOP) ;EP
;---> CALL TO ^DDS
;---> NOTE: Screenman automatically uses incremental locks.
;---> Parameters:
; 1 - DDSFILE=FILE# (req)
; 2 - DR=FORM (req)
; 3 - DA=RECORD (req)
; 4 - DDSPARM (C/E) (opt) C=Register change in DDSCHANG
; 5 - DDSSAVE (ret) $G(DDSSAVE)=1 if user saved changes.
; 6 - BIPOP (ret) FAIL/QUIT/TIMEOUT
;
;---> Examples:
; D DDS^BIFMAN(9002086.02,"[BI SITE PARAMS-FORM-1]",+Y)
; D DDS^BIFMAN(9002086.1,"[BI PROC-FORM-LAB]",DA,"C",.BICHG,.BIPOP)
;
N BIDA,X,Y S BIDA=DA,BIPOP=0
I DDSFILE S DDSFILE=^DIC(DDSFILE,0,"GL")
I $G(BIDA) L +@(DDSFILE_BIDA_")"):5 I '$T S BIPOP=1 D LOCKED^BIUTL3 Q
K ^TMP("DDS",$J)
I '$D(IOST(0)) D HOME^%ZIS,ENS^%ZISS
D ^DDS
S:$D(DTOUT) BIPOP=1
I $D(DIMSG)!($D(DIERR)) D S BIPOP=1
.W !?5,"* The Screen Manager could not edit this record."
.W !?7,"Please contact your Site Manager." D DIRZ^BIUTL3(.BIPOP)
I $G(BIDA) L -@(DDSFILE_BIDA_")")
D DKILLS
Q
;
;
;----------
DIE(DIE,DR,DA,BIPOP,Z) ;EP
;---> CALL TO ^DIE - Edit entry in a file.
;---> Parameters:
; 1 - DIE=DIE (req)
; 2 - DR=DR (req)
; 3 - DA=DA (req)
; 4 - BIPOP (ret) BIPOP=1 indicates failure/quit
; 5 - Z (opt) Z=1 if user should *NOT* be notified
; record was locked.
;
;---> Example: D DIE^BIFMAN(9002086,DR,+Y,.BIPOP)
; (+Y from DIC call, DR could be literal if short.)
;
N BIDA,X,Y S BIDA=DA,BIPOP=0
I DIE S DIE=^DIC(DIE,0,"GL")
L +@(DIE_BIDA_")"):5 I '$T S BIPOP=1 D:'$G(Z) LOCKED^BIUTL3 Q
D ^DIE
S:($D(DTOUT))!($D(Y)) BIPOP=1
L -@(DIE_BIDA_")")
D DKILLS
Q
;
;
;----------
FDIE(BIFN,BIIENS,BIFLD,BIERR,BIEXT) ;EP - Call to FILE^DIE.
;---> CALL TO FILE^DIE - File validated data into an *EXISTING* entry in a file.
;---> Parameters:
; 1 - BIFN (req) File Number.
; 2 - BIIENS (req) IENS comma-delimited String.
; 3 - BIFLD (req) Array of BIFLD(Field#)=Value
; 4 - BIERR (ret) Text of error, if any.
; 5 - BIEXT (opt) If BIEXT=1, tell FILE^DIE values are External.
;
;---> Example:
;---> Build FDA field=value array.
;N BIFLD
;S BIFLD(.08)=E
;S BIFLD(.09)=C
;S BIFLD(.1)=B
;S BIFLD(.11)=D
;
;---> Store edit data.
;---> Example: D FDIE^BIFMAN(9002084,+BIIEN,.BIFLD,.BIERR)
;
;
N BIDA,BIFDA,BIGBL,BIMSG
;
;---Check for valid File Number and Data Dictionary.
I '$G(BIFN) D ERRCD^BIUTL2(671,.BIERR) Q
I '$D(^DD($G(BIFN),0)) D ERRCD^BIUTL2(671,.BIERR) Q
;
;---> Check for valid IEN.
I '$G(BIIENS) D ERRCD^BIUTL2(672,.BIERR) Q
;---> Append mandatory terminating comma to IENS if not present.
S:($E(BIIENS,$L(BIIENS))'=",") BIIENS=BIIENS_","
S BIDA=$P(BIIENS,",",($L(BIIENS,",")-1))
;
;---Check for valid global.
S BIGBL=$G(^DIC(BIFN,0,"GL"))
I BIGBL="" D ERRCD^BIUTL2(601,.BIERR) Q
;
;---> Check for existence of the top level entry to be edited.
I '$D(@(BIGBL_BIDA_",0)")) D ERRCD^BIUTL2(673,.BIERR) Q
;
;---> Lock entry or quit if unavailable.
L +@(BIGBL_BIDA_")"):5 I '$T D ERRCD^BIUTL2(670,.BIERR) Q
;
;---> Process External/Internal Flag value.
S BIEXT=$S($G(BIEXT)=1:"E",1:"")
;
;---> Create FDA.
N N S N=0
F S N=$O(BIFLD(N)) Q:'N D
.S BIFDA(BIFN,BIIENS,N)=BIFLD(N)
;
D FILE^DIE(BIEXT,"BIFDA","BIMSG")
L -@(BIGBL_BIDA_")")
S BIERR=$G(BIMSG("DIERR",1,"TEXT",1))
I BIERR'="" S BIERR=$E(BIERR,1,($L(BIERR)-1))_" (software error). #674"
D DKILLS
Q
;
;
;----------
DIR(DIR0,Y,BIPOP,DIRA,DIRB,DIRQ,DIRQ1) ;EP
;---> Call to ^DIR - General purpose reader, for prompts, etc.
;---> Parameters:
; 1 - DIR0=DIR(0) (req) Indicate type of read
; 2 - Y (ret) From call to ^DIR
; 3 - BIPOP (ret) BIPOP=1 if DIRUT
; 4 - DIRA=DIR("A") (opt) Prompt
; 5 - DIRB=DIR("B") (opt) Default
; 6 - DIRQ=DIR("?") (opt) Help
; 7 - DIRQ1=DIR("?",1) (opt) Addtional help
;
;---> Example: D DIR^BIFMAN("SAM",.Y,.BIPOP," Select FORMAT: ")
;
I $G(DIR0)']"" S BIPOP=1 Q
N DIR,X S BIPOP=0,DIR(0)=DIR0
S:$G(DIRA)]"" DIR("A")=DIRA
S:$G(DIRB)]"" DIR("B")=DIRB
S:$G(DIRQ)]"" DIR("?")=DIRQ
S:$G(DIRQ1)]"" DIR("?",1)=DIRQ1
D ^DIR
S:$D(DIRUT) BIPOP=1
D DKILLS
Q
;
;
YESNO ; EP
;---> * NOT USED! *
;---> Sample Code for Yes/No question.
W !!?3,"Should this patient's Status be Yes or No?",!
N DIR
S DIR(0)="YA" ; Add "O" (YAO) to make answer optional.
; ; "A" means Append nothing to the DIR("A") prompt.
S DIR("A")=" Enter Yes or No: " ; Prompt.
S DIR("B")="NO" ; Default.
S DIR("?",1)=" Enter YES to say Yes." ; First line of "?" help.
S DIR("?")=" Enter No to say No." ; Last line of "?" help.
D ^DIR W !
;---> If answer is YES, Y=1.
D:Y=1
.N BIFLD,BIERR S BIFLD(.08)="",BIFLD(.16)=""
.D FDIE^BIFMAN(9002084,BIDFN,.BIFLD,.BIERR,1)
.I $G(BIERR)]"" W !!?3,BIERR D DIRZ^BIUTL3() S BIPOP=1
Q
;
;
;----------
FILE(DIC,X,DIC0,DICDR,DINUM,Y,BIPOP) ; EP - Call FILE^DICN
;---> Add a new entry to a file.
;---> Parameters:
; 1 - DIC (req) DIC, numeric or global ref
; 2 - X (req) .01 value to be added
; 3 - DIC0 (req) DIC(0), input parameter string
; 4 - DICDR (opt) DIC("DR")
; 5 - DINUM (opt) IEN of entry to be added
; 6 - Y (ret) Value of Y returned by ^DICN
; 7 - BIPOP (ret) BIPOP=1 if DTOUT OR DUOUT
;
;---> Example: D FILE^BIFMAN(9002084.35,N,"ML",".02////3")
;
K DD,DO
I DIC S DLAYGO=DIC,DIC=^DIC(DIC,0,"GL")
S:$G(DICDR)]"" DIC("DR")=DICDR S DIC(0)=DIC0
D FILE^DICN
S BIPOP=$S(($D(DTOUT)!($D(DUOUT))):1,1:0)
D DKILLS
Q
;
;
;----------
DIK ; EP - CALL ^DIK
D ^DIK
D DKILLS
Q
;
;
;----------
DIQ ; EP - CALL ^DIQ
D EN^DIQ
D DKILLS
Q
;
;
;----------
DIQ1 ; EP - CALL ^DIQ1
D EN^DIQ1
D DKILLS
Q
;
;
;----------
DKILLS ;EP
K D,D0,D1,DA,DD,DDH,DI,DIADD,DIC,DIC1,DICR,DIE,DIG,DIH,DIK,DILC
K DINUM,DIRUT,DIQ,DIQ2,DIR,DIU,DIW,DIWF,DIWL,DIWR,DIWT,DK,DL
K DLAYGO,DN,DQ,DR,DTOUT,DUOUT,DX
D CLEAN^DILF
Q
BIFMAN ;IHS/CMI/MWR - FILEMAN CALLS; MAY 10, 2010
+1 ;;8.5;IMMUNIZATION;;SEP 01,2011
+2 ;;* MICHAEL REMILLARD, DDS * CIMARRON MEDICAL INFORMATICS, FOR IHS *
+3 ;; CALLS TO FILEMAN WITH PRE- AND POST-CALL VARIABLE SETTING.
+4 ;
+5 ;
+6 ;----------
DIC(DIC,DIC0,BIY,DICA,DICB,DICS,BIX,BIPOP,DICDR) ;EP
+1 ;---> CALL TO ^DIC - File lookup and/or add new entry.
+2 ;---> Parameters:
+3 ; 1 - DIC=DIC (req)
+4 ; 2 - DIC0=DIC(0) (req)
+5 ; 3 - BIY (ret) Equal to Y from call to ^DIC.
+6 ; 4 - DICA=DIC("A") (opt) Prompt
+7 ; 5 - DICB=DIC("B") (opt) DEFAULT
+8 ; 6 - DICS=DIC("S") (opt) Screen
+9 ; 7 - BIX (opt) Equal to X if DIC(0)'["A".
+10 ; 8 - BIPOP (opt) BIPOP=1 if DTOUT or DUOUT
+11 ; 9 - DICDR=DIC("DR") (opt) To specify fields to be asked when
+12 ; adding a new entry.
+13 ;
+14 ;---> Example: D DIC^BIFMAN(9002086,"QEMAL",.Y," Select PATIENT: ")
+15 ; To stuff an entry:
+16 ; D DIC^BIFMAN(9002086,"QEML",.Y,,,,"NewEntry")
+17 ;
+18 NEW X,Y
+19 IF $GET(BIX)]""
SET X=BIX
+20 IF $GET(DIC)']""!($GET(DIC0)']"")
SET BIPOP=1
QUIT
+21 SET BIPOP=0
IF DIC
SET DLAYGO=$PIECE(DIC,".")
+22 SET DIC(0)=DIC0
+23 IF $GET(DICA)]""
SET DIC("A")=DICA
+24 IF $GET(DICB)]""
SET DIC("B")=DICB
+25 IF $GET(DICDR)]""
SET DIC("DR")=DICDR
+26 IF $GET(DICS)]""
SET DIC("S")=DICS
+27 DO ^DIC
+28 SET BIY=Y
+29 IF ($DATA(DTOUT))!($DATA(DUOUT))
SET BIPOP=1
+30 DO DKILLS
+31 QUIT
+32 ;
+33 ;
+34 ;----------
UPDATE(BIFN,BIIEN,BIFLD,BIERR,BIEXT) ;EP
+1 ;---> CALL TO UPDATE^DIE - To *ADD* new entry or subentry to a file.
+2 ;---> Parameters:
+3 ; 1 - BIFN (req) File Number.
+4 ; 2 - BIIEN (opt) IENS Array setting Seq Number=desire IEN in global.
+5 ; 3 - BIFLD (req) Array of BIFLD(Field#)=Value, esp. need a .01 node,
+6 ; may need other required fields.
+7 ; 4 - BIERR (ret) Text of error, if any.
+8 ; 5 - BIEXT (opt) If BIEXT="E", tell UPDATE^DIE values are External.
+9 ;
+10 ;---> Example: N BIERR,BIFLD,BIIEN
+11 ; S BIIEN(1)=777 (This is to S DINUM=X; specify IEN in global)
+12 ; S BIFLD(.01)=777
+13 ; S BIFLD(.02)="This is a test of UPDATE~DIE."
+14 ; D UPDATE^BIFMAN(9002084.33,.BIIEN,.BIFLD,.BIERR)
+15 ; I $G(BIERR)]"" W !!?3,BIERR D DIRZ^BIUTL3()
+16 ; OR
+17 ; NOTE!: 2nd Parameter, BIIEN, is optional;
+18 ; But you must set BIFLD(.01)=something.
+19 ; N BIERR,BIFLD
+20 ; S BIFLD(.01)=BIDFN,BIFLD(.02)=BIPTR,BIFLD(.03)=BIREAS
+21 ; D UPDATE^BIFMAN(9002084.11,,.BIFLD,.BIERR)
+22 ;
+23 NEW BIFDA,BIMSG,BISEQN
+24 ;
+25 ;---Check for valid File Number and Data Dictionary.
+26 IF '$GET(BIFN)
DO ERRCD^BIUTL2(671,.BIERR)
QUIT
+27 IF '$DATA(^DD($GET(BIFN),0))
DO ERRCD^BIUTL2(671,.BIERR)
QUIT
+28 ;
+29 ;---> Set BISEQN is Sequence Number #1 set to ADD new top level entry.
+30 SET BISEQN="+1,"
+31 ;---> Process External/Internal Flag value.
+32 SET BIEXT=$SELECT($GET(BIEXT)=1:"E",1:"")
+33 ;
+34 ;---> Create FDA.
+35 NEW N
SET N=0
+36 FOR
SET N=$ORDER(BIFLD(N))
IF 'N
QUIT
Begin DoDot:1
+37 SET BIFDA(BIFN,BISEQN,N)=BIFLD(N)
End DoDot:1
+38 ;
+39 DO UPDATE^DIE(BIEXT,"BIFDA","BIIEN","BIMSG")
+40 ;
+41 SET BIERR=$GET(BIMSG("DIERR",1,"TEXT",1))
+42 IF BIERR'=""
SET BIERR=BIERR_" (software error) #674"
+43 DO DKILLS
+44 QUIT
+45 ;
+46 ;
+47 ;----------
DDS(DDSFILE,DR,DA,DDSPARM,DDSSAVE,BIPOP) ;EP
+1 ;---> CALL TO ^DDS
+2 ;---> NOTE: Screenman automatically uses incremental locks.
+3 ;---> Parameters:
+4 ; 1 - DDSFILE=FILE# (req)
+5 ; 2 - DR=FORM (req)
+6 ; 3 - DA=RECORD (req)
+7 ; 4 - DDSPARM (C/E) (opt) C=Register change in DDSCHANG
+8 ; 5 - DDSSAVE (ret) $G(DDSSAVE)=1 if user saved changes.
+9 ; 6 - BIPOP (ret) FAIL/QUIT/TIMEOUT
+10 ;
+11 ;---> Examples:
+12 ; D DDS^BIFMAN(9002086.02,"[BI SITE PARAMS-FORM-1]",+Y)
+13 ; D DDS^BIFMAN(9002086.1,"[BI PROC-FORM-LAB]",DA,"C",.BICHG,.BIPOP)
+14 ;
+15 NEW BIDA,X,Y
SET BIDA=DA
SET BIPOP=0
+16 IF DDSFILE
SET DDSFILE=^DIC(DDSFILE,0,"GL")
+17 IF $GET(BIDA)
LOCK +@(DDSFILE_BIDA_")"):5
IF '$TEST
SET BIPOP=1
DO LOCKED^BIUTL3
QUIT
+18 KILL ^TMP("DDS",$JOB)
+19 IF '$DATA(IOST(0))
DO HOME^%ZIS
DO ENS^%ZISS
+20 DO ^DDS
+21 IF $DATA(DTOUT)
SET BIPOP=1
+22 IF $DATA(DIMSG)!($DATA(DIERR))
Begin DoDot:1
+23 WRITE !?5,"* The Screen Manager could not edit this record."
+24 WRITE !?7,"Please contact your Site Manager."
DO DIRZ^BIUTL3(.BIPOP)
End DoDot:1
SET BIPOP=1
+25 IF $GET(BIDA)
LOCK -@(DDSFILE_BIDA_")")
+26 DO DKILLS
+27 QUIT
+28 ;
+29 ;
+30 ;----------
DIE(DIE,DR,DA,BIPOP,Z) ;EP
+1 ;---> CALL TO ^DIE - Edit entry in a file.
+2 ;---> Parameters:
+3 ; 1 - DIE=DIE (req)
+4 ; 2 - DR=DR (req)
+5 ; 3 - DA=DA (req)
+6 ; 4 - BIPOP (ret) BIPOP=1 indicates failure/quit
+7 ; 5 - Z (opt) Z=1 if user should *NOT* be notified
+8 ; record was locked.
+9 ;
+10 ;---> Example: D DIE^BIFMAN(9002086,DR,+Y,.BIPOP)
+11 ; (+Y from DIC call, DR could be literal if short.)
+12 ;
+13 NEW BIDA,X,Y
SET BIDA=DA
SET BIPOP=0
+14 IF DIE
SET DIE=^DIC(DIE,0,"GL")
+15 LOCK +@(DIE_BIDA_")"):5
IF '$TEST
SET BIPOP=1
IF '$GET(Z)
DO LOCKED^BIUTL3
QUIT
+16 DO ^DIE
+17 IF ($DATA(DTOUT))!($DATA(Y))
SET BIPOP=1
+18 LOCK -@(DIE_BIDA_")")
+19 DO DKILLS
+20 QUIT
+21 ;
+22 ;
+23 ;----------
FDIE(BIFN,BIIENS,BIFLD,BIERR,BIEXT) ;EP - Call to FILE^DIE.
+1 ;---> CALL TO FILE^DIE - File validated data into an *EXISTING* entry in a file.
+2 ;---> Parameters:
+3 ; 1 - BIFN (req) File Number.
+4 ; 2 - BIIENS (req) IENS comma-delimited String.
+5 ; 3 - BIFLD (req) Array of BIFLD(Field#)=Value
+6 ; 4 - BIERR (ret) Text of error, if any.
+7 ; 5 - BIEXT (opt) If BIEXT=1, tell FILE^DIE values are External.
+8 ;
+9 ;---> Example:
+10 ;---> Build FDA field=value array.
+11 ;N BIFLD
+12 ;S BIFLD(.08)=E
+13 ;S BIFLD(.09)=C
+14 ;S BIFLD(.1)=B
+15 ;S BIFLD(.11)=D
+16 ;
+17 ;---> Store edit data.
+18 ;---> Example: D FDIE^BIFMAN(9002084,+BIIEN,.BIFLD,.BIERR)
+19 ;
+20 ;
+21 NEW BIDA,BIFDA,BIGBL,BIMSG
+22 ;
+23 ;---Check for valid File Number and Data Dictionary.
+24 IF '$GET(BIFN)
DO ERRCD^BIUTL2(671,.BIERR)
QUIT
+25 IF '$DATA(^DD($GET(BIFN),0))
DO ERRCD^BIUTL2(671,.BIERR)
QUIT
+26 ;
+27 ;---> Check for valid IEN.
+28 IF '$GET(BIIENS)
DO ERRCD^BIUTL2(672,.BIERR)
QUIT
+29 ;---> Append mandatory terminating comma to IENS if not present.
+30 IF ($EXTRACT(BIIENS,$LENGTH(BIIENS))'=",")
SET BIIENS=BIIENS_","
+31 SET BIDA=$PIECE(BIIENS,",",($LENGTH(BIIENS,",")-1))
+32 ;
+33 ;---Check for valid global.
+34 SET BIGBL=$GET(^DIC(BIFN,0,"GL"))
+35 IF BIGBL=""
DO ERRCD^BIUTL2(601,.BIERR)
QUIT
+36 ;
+37 ;---> Check for existence of the top level entry to be edited.
+38 IF '$DATA(@(BIGBL_BIDA_",0)"))
DO ERRCD^BIUTL2(673,.BIERR)
QUIT
+39 ;
+40 ;---> Lock entry or quit if unavailable.
+41 LOCK +@(BIGBL_BIDA_")"):5
IF '$TEST
DO ERRCD^BIUTL2(670,.BIERR)
QUIT
+42 ;
+43 ;---> Process External/Internal Flag value.
+44 SET BIEXT=$SELECT($GET(BIEXT)=1:"E",1:"")
+45 ;
+46 ;---> Create FDA.
+47 NEW N
SET N=0
+48 FOR
SET N=$ORDER(BIFLD(N))
IF 'N
QUIT
Begin DoDot:1
+49 SET BIFDA(BIFN,BIIENS,N)=BIFLD(N)
End DoDot:1
+50 ;
+51 DO FILE^DIE(BIEXT,"BIFDA","BIMSG")
+52 LOCK -@(BIGBL_BIDA_")")
+53 SET BIERR=$GET(BIMSG("DIERR",1,"TEXT",1))
+54 IF BIERR'=""
SET BIERR=$EXTRACT(BIERR,1,($LENGTH(BIERR)-1))_" (software error). #674"
+55 DO DKILLS
+56 QUIT
+57 ;
+58 ;
+59 ;----------
DIR(DIR0,Y,BIPOP,DIRA,DIRB,DIRQ,DIRQ1) ;EP
+1 ;---> Call to ^DIR - General purpose reader, for prompts, etc.
+2 ;---> Parameters:
+3 ; 1 - DIR0=DIR(0) (req) Indicate type of read
+4 ; 2 - Y (ret) From call to ^DIR
+5 ; 3 - BIPOP (ret) BIPOP=1 if DIRUT
+6 ; 4 - DIRA=DIR("A") (opt) Prompt
+7 ; 5 - DIRB=DIR("B") (opt) Default
+8 ; 6 - DIRQ=DIR("?") (opt) Help
+9 ; 7 - DIRQ1=DIR("?",1) (opt) Addtional help
+10 ;
+11 ;---> Example: D DIR^BIFMAN("SAM",.Y,.BIPOP," Select FORMAT: ")
+12 ;
+13 IF $GET(DIR0)']""
SET BIPOP=1
QUIT
+14 NEW DIR,X
SET BIPOP=0
SET DIR(0)=DIR0
+15 IF $GET(DIRA)]""
SET DIR("A")=DIRA
+16 IF $GET(DIRB)]""
SET DIR("B")=DIRB
+17 IF $GET(DIRQ)]""
SET DIR("?")=DIRQ
+18 IF $GET(DIRQ1)]""
SET DIR("?",1)=DIRQ1
+19 DO ^DIR
+20 IF $DATA(DIRUT)
SET BIPOP=1
+21 DO DKILLS
+22 QUIT
+23 ;
+24 ;
YESNO ; EP
+1 ;---> * NOT USED! *
+2 ;---> Sample Code for Yes/No question.
+3 WRITE !!?3,"Should this patient's Status be Yes or No?",!
+4 NEW DIR
+5 ; Add "O" (YAO) to make answer optional.
SET DIR(0)="YA"
+6 ; ; "A" means Append nothing to the DIR("A") prompt.
+7 ; Prompt.
SET DIR("A")=" Enter Yes or No: "
+8 ; Default.
SET DIR("B")="NO"
+9 ; First line of "?" help.
SET DIR("?",1)=" Enter YES to say Yes."
+10 ; Last line of "?" help.
SET DIR("?")=" Enter No to say No."
+11 DO ^DIR
WRITE !
+12 ;---> If answer is YES, Y=1.
+13 IF Y=1
Begin DoDot:1
+14 NEW BIFLD,BIERR
SET BIFLD(.08)=""
SET BIFLD(.16)=""
+15 DO FDIE^BIFMAN(9002084,BIDFN,.BIFLD,.BIERR,1)
+16 IF $GET(BIERR)]""
WRITE !!?3,BIERR
DO DIRZ^BIUTL3()
SET BIPOP=1
End DoDot:1
+17 QUIT
+18 ;
+19 ;
+20 ;----------
FILE(DIC,X,DIC0,DICDR,DINUM,Y,BIPOP) ; EP - Call FILE^DICN
+1 ;---> Add a new entry to a file.
+2 ;---> Parameters:
+3 ; 1 - DIC (req) DIC, numeric or global ref
+4 ; 2 - X (req) .01 value to be added
+5 ; 3 - DIC0 (req) DIC(0), input parameter string
+6 ; 4 - DICDR (opt) DIC("DR")
+7 ; 5 - DINUM (opt) IEN of entry to be added
+8 ; 6 - Y (ret) Value of Y returned by ^DICN
+9 ; 7 - BIPOP (ret) BIPOP=1 if DTOUT OR DUOUT
+10 ;
+11 ;---> Example: D FILE^BIFMAN(9002084.35,N,"ML",".02////3")
+12 ;
+13 KILL DD,DO
+14 IF DIC
SET DLAYGO=DIC
SET DIC=^DIC(DIC,0,"GL")
+15 IF $GET(DICDR)]""
SET DIC("DR")=DICDR
SET DIC(0)=DIC0
+16 DO FILE^DICN
+17 SET BIPOP=$SELECT(($DATA(DTOUT)!($DATA(DUOUT))):1,1:0)
+18 DO DKILLS
+19 QUIT
+20 ;
+21 ;
+22 ;----------
DIK ; EP - CALL ^DIK
+1 DO ^DIK
+2 DO DKILLS
+3 QUIT
+4 ;
+5 ;
+6 ;----------
DIQ ; EP - CALL ^DIQ
+1 DO EN^DIQ
+2 DO DKILLS
+3 QUIT
+4 ;
+5 ;
+6 ;----------
DIQ1 ; EP - CALL ^DIQ1
+1 DO EN^DIQ1
+2 DO DKILLS
+3 QUIT
+4 ;
+5 ;
+6 ;----------
DKILLS ;EP
+1 KILL D,D0,D1,DA,DD,DDH,DI,DIADD,DIC,DIC1,DICR,DIE,DIG,DIH,DIK,DILC
+2 KILL DINUM,DIRUT,DIQ,DIQ2,DIR,DIU,DIW,DIWF,DIWL,DIWR,DIWT,DK,DL
+3 KILL DLAYGO,DN,DQ,DR,DTOUT,DUOUT,DX
+4 DO CLEAN^DILF
+5 QUIT
