- BEHOARMU ;MSC/IND/MGH - ART Enhancements for meaningful use ;06-Jul-2012 08:29;DU
- ;;1.1;BEH COMPONENTS;**045004,045006**;Sep 18, 2007;Build 1
- ;=================================================================
- ;Return the values that can be selected for the chosen field
- ;Inp=file^field
- ;Return= Array of values that can be used for this field in this file
- REASONS(RET,FLG) ;EP List of reasons
- N IEN,CNT,X,Y
- S RET=$$TMPGBL()
- S CNT=0
- S IEN=0 F S IEN=$O(^BEHOAR(90460.05,IEN)) Q:'+IEN D
- .I $P($G(^BEHOAR(90460.05,IEN,0)),U,2)=FLG D
- ..S CNT=CNT+1
- ..S X=$P($G(^BEHOAR(90460.05,IEN,0)),U,3)
- ..S @RET@(CNT,0)=IEN_U_$P($G(^BEHOAR(90460.05,IEN,0)),U,1)_U_$S(X="Y":1,X="N":0,1:0)
- Q
- SNOMED(RET) ;EP List of snomed codes
- N IEN,CNT,NAME
- S RET=$$TMPGBL()
- S CNT=0
- S NAME="" F S NAME=$O(^BEHOAR(90460.06,"B",NAME)) Q:NAME="" D
- .S IEN=0 F S IEN=$O(^BEHOAR(90460.06,"B",NAME,IEN)) Q:IEN="" D
- ..Q:+$P($G(^BEHOAR(90460.06,IEN,0)),U,4)
- ..S CNT=CNT+1
- ..S @RET@(CNT,0)=IEN_U_$P($G(^BEHOAR(90460.06,IEN,0)),U,1)_U_$P($G(^BEHOAR(90460.06,IEN,0)),U,2)
- Q
- ;Mark an allergy as entered in error
- ;Input
- ; IEN=Entry number in the 120.8 file
- ; DFN=Patient's internal entry number
- ; VAL=Array of values to be stored
- ; ("GMRAERR")=Indicates this entry is to be marked EIE
- ; ("GMRAERRBY")=User marking it (optional,will set to DUZ)
- ; ("GMRAERRDT")=Date/time EIE (option,will set to NOW)
- ; ("GMRAERCMTS")=N Comment lines for entering in error
- ; ("GMRAERRCMTS",n)
- ; OUPUT = error message or IEN of entry marked in error
- EIE(DATA,IEN,DFN,VAL) ;entered in error
- N NOW,ORNODE,GMR0
- S GMR0=$P($G(^GMR(120.8,IEN,0)),U),DATA=""
- I '$L(GMR0) S DATA="-1^Entry not found" Q
- D CKIN(DFN)
- S NOW=$$NOW^XLFDT
- I $G(VAL("GMRAERRBY"))="" S VAL("GMRAERRBY")=DUZ
- I $G(VAL("GMRAERRDT"))="" S VAL("GMRAERRDT")=NOW
- S ORNODE=$NAME(^TMP("GMRA",$J))
- K @ORNODE M @ORNODE=VAL
- D EIE^GMRAGUI1(IEN,DFN,ORNODE)
- S DATA=IEN
- D FIREEVT^BEHOART(DFN,2,IEN)
- Q
- ;Mark an allergy as inactivated
- ;Input
- ; IEN=Entry number in the 120.8 file
- ; DFN=Patient's internal entry number
- ; VAL=Array of values to be stored
- ; ("GMRAINACT")=Date entry marked inactive (required)
- ; ("GMRAINACBY")=User marking it (optional,will set to DUZ)
- ; ("GMRAINWHY")=Reason marked inactive^comment if OTHER
- ; OUPUT = error message or IEN of entry marked inactive
- INACT(DATA,IEN,DFN,VAL) ;inactive allergies
- N X,Y,STOP,FNUM,AIEN,ERR,WHY,WHYIEN
- I IEN="" S DATA="-1^Missing entry to inactivate" Q
- D CKIN(DFN)
- S STOP=0,FNUM=120.899999912
- S AIEN="+1,"_IEN_","
- S FDA(120.899999912,AIEN,.01)=$G(VAL("GMRAINACT"))
- S WHY=$G(VAL("GMRAINWHY"))
- S WHYIEN=$$REASON(WHY)
- I WHYIEN S FDA(120.899999912,AIEN,1)=$P(WHYIEN,U,1)
- I $G(VAL("GMRAINACBY"))="" S VAL("GMRAINACBY")=DUZ
- S FDA(120.899999912,AIEN,2)=$G(VAL("GMRAINACBY"))
- I $D(VAL("GMRACMTS")) D GMRACMTS^BEHOART
- D UPDATE^DIE(,"FDA","IEN","ERR")
- S DATA=+IEN
- D FIREEVT^BEHOART(DFN,1,IEN)
- K FDA,ERR
- Q
- ;Input
- ; IEN=Entry number in the 120.8 file
- ; DFN=Patient's internal entry number
- ; VAL=Array of values to be stored
- ; ("GMRAINRE")=Date/Time to reactivate (required to reactivate)
- ; ("GMRAINREBY")=User reactivating (optional,will set to DUZ)
- ; OUPUT = error message or IEN of entry marked inactive
- REACT(DATA,IEN,DFN,VAL) ;reactivate allergy
- N X,Y,STOP,FNUM,AIEN,BIEN,ERR,SIEN,SIEN,MIEN,CANVER
- I IEN="" S DATA="-1^Missing entry to reactivate" Q
- D CKIN(DFN)
- S STOP=0,FNUM=120.899999912,BIEN=IEN
- S SIEN=$O(^GMR(120.8,IEN,9999999.12,$C(0)),-1)
- I STOP!'SIEN S DATA="-1^Unable to find entry to reactivate" Q
- S AIEN=SIEN_","_IEN_","
- I $G(VAL("GMRAINREBY"))="" S VAL("GMRAINREBY")=DUZ
- I $G(VAL("GMRAINRE"))="" S VAL("GMRAINRE")=$$NOW^XLFDT
- ;S FDA(120.899999912,AIEN,.01)=$G(VAL("GMRAINACT"))
- S FDA(120.899999912,AIEN,3)=$G(VAL("GMRAINRE"))
- S FDA(120.899999912,AIEN,4)=$G(VAL("GMRAINREBY"))
- D UPDATE^DIE(,"FDA","IEN","ERR")
- K FDA,ERR
- ;Remove the verification, must be redone
- S AIEN=BIEN_","
- S FDA(120.8,AIEN,15)="@"
- S FDA(120.8,AIEN,19)="@"
- S FDA(120.8,AIEN,20)="@"
- S FDA(120.8,AIEN,21)="@"
- D FILE^DIE("","FDA","ERR")
- S DATA=IEN
- D FIREEVT^BEHOART(DFN,1,IEN)
- ;Patch 11 changed to autosign
- S CANVER=$$HASKEY^BEHOUSCX("GMRA-ALLERGY VERIFY")
- D:$$CANSIGN^BEHOART(DATA) SIGN^BEHOART(.SIG,DATA,CANVER) ;AUTOSIGN
- ;D SNDALR^BEHOART(DATA,1)
- K FDA,ERR
- Q
- ;
- ;Add or release an allergy assessment of unassessable
- ;Input
- ; IEN=Entry in the 120.86 file (Blank if pt not in file)
- ; DFN=Patient's internal entry number
- ; VAL=array of values to be stored
- ; ("GMRAACC")=Date entry marked unassessable
- ; ("GMRAACRE")=Reason marked unassessable
- ; ("GMRAACCBY")=User marking record as unassessable
- ; OUPUT = error messagte or IEN of entry marked unassessable
- ASSESS(DATA,IEN,DFN,VAL) ;mark unassessible
- N FNUM,NEW,X,ATIME,FDA,BIEN,AIEN,FDA2,AIEN2,WHY,WHYIEN,IEN,ACTION
- S FNUM=120.869999911
- I '$D(^GMR(120.86,DFN,0)) D
- .S AIEN="+1,",FDA(120.86,AIEN,.01)=DFN
- .S IEN(1)=DFN
- .D UPDATE^DIE(,"FDA","IEN","ERR")
- .I 'IEN(1) S DATA="-1^Unable to update allergy assessment"
- ;See if there are any earlier unable to assess nodes not closed out
- S ACTION=1
- K FDA,IEN,ERR,AIEN
- D CKIN(DFN)
- S WHY=$G(VAL("GMRAACRE"))
- S WHYIEN=$$REASON(WHY)
- I 'WHYIEN D Q
- .S DATA="-1^A valid reason was not submitted"
- S AIEN="+1,"_DFN_","
- S FDA(120.869999911,AIEN,.01)=VAL("GMRAACC")
- S FDA(120.869999911,AIEN,1)=$P(WHYIEN,U,1)
- I $P(WHYIEN,U,2)'="" S FDA(120.869999911,AIEN,5)=$P(WHYIEN,U,2)
- I $G(VAL("GMRAACCBY"))="" S VAL("GMRAACBY")=DUZ
- S FDA(120.869999911,AIEN,2)=VAL("GMRAACCBY")
- D UPDATE^DIE(,"FDA","IEN","ERR")
- S DATA=+$G(IEN(1))
- D QUEUE^CIANBEVT("GMRA."_DFN,ACTION)
- Q
- ;Input
- ; IEN=Entry in the 120.86 file (Blank if pt not in file)
- ; DFN=Patient's internal entry number
- ; VAL=array of values to be stored
- ; ("GMRAACC")=Date entry marked unassessable
- ; ("GMRAACCRE")="Date unassessible resolved"
- ; ("GMRAACCBY")="User unmarking the unacessable"
- ; OUPUT = error messagte or IEN of entry marked unassessable
- REASSESS(DATA,IEN,DFN,VAL) ;reactivate
- ;Find node to close out
- N AIEN,STOP,BIEN,ATIME
- S STOP=0
- S ATIME=9999999 F S ATIME=$O(^GMR(120.86,DFN,9999999.11,"B",ATIME),-1) Q:'ATIME!(STOP=1) D
- .S AIEN="" F S AIEN=$O(^GMR(120.86,DFN,9999999.11,"B",ATIME,AIEN)) Q:'+AIEN!(STOP=1) D
- ..I ATIME=VAL("GMRAACC") S STOP=1
- ..S BIEN=AIEN_","_DFN_","
- ..I $G(VAL("GMRAACRE"))="" S VAL("GMRAACRE")=$$NOW^XLFDT
- ..S FDA(120.869999911,BIEN,3)=VAL("GMRAACRE")
- ..I $G(VAL("GMRAACCBY"))="" S VAL("GMRAACCBY")=DUZ
- ..S FDA(120.869999911,BIEN,4)=VAL("GMRAACCBY")
- ..D UPDATE^DIE(,"FDA","IEN","ERR")
- ..I '$D(ERR) S DATA=IEN
- ..K FDA,IEN,ERR
- ..D FIREEVT^BEHOART(DFN,2,"")
- Q
- ;See if there are any earlier unable to assess nodes not closed out
- ;If so, close them out
- CKIN(DFN) ;
- N ATIME,AIEN,BIEN,FDA2,IEN,ERR
- S ATIME=9999999 F S ATIME=$O(^GMR(120.86,DFN,9999999.11,"B",ATIME),-1) Q:ATIME="" D
- .S BIEN="" F S BIEN=$O(^GMR(120.86,DFN,9999999.11,"B",ATIME,BIEN)) Q:BIEN="" D
- ..I $P($G(^GMR(120.86,DFN,9999999.11,BIEN,0)),U,4)="" D
- ...S AIEN=BIEN_","_DFN_","
- ...S FDA2(120.869999911,AIEN,3)=$$NOW^XLFDT
- ...S FDA2(120.869999911,AIEN,4)=DUZ
- ...D UPDATE^DIE(,"FDA2","IEN","ERR")
- ...K FDA2,IEN,ERR
- Q
- ; Return IEN to BEH ALLERGY VALUES file
- REASON(VAL) ; EP -
- N X,RET,COM
- I +VAL>0 S RET=+VAL
- E S X=$P(VAL,U,2) S RET=$O(^BEHOAR(90460.05,"B",X,""))
- S COM=$P(VAL,U,4)
- I COM'="" S RET=RET_U_COM
- Q RET
- ;
- TMPGBL() K ^TMP("BEHOART",$J) Q $NA(^($J))
- BEHOARMU ;MSC/IND/MGH - ART Enhancements for meaningful use ;06-Jul-2012 08:29;DU
- +1 ;;1.1;BEH COMPONENTS;**045004,045006**;Sep 18, 2007;Build 1
- +2 ;=================================================================
- +3 ;Return the values that can be selected for the chosen field
- +4 ;Inp=file^field
- +5 ;Return= Array of values that can be used for this field in this file
- REASONS(RET,FLG) ;EP List of reasons
- +1 NEW IEN,CNT,X,Y
- +2 SET RET=$$TMPGBL()
- +3 SET CNT=0
- +4 SET IEN=0
- FOR
- SET IEN=$ORDER(^BEHOAR(90460.05,IEN))
- IF '+IEN
- QUIT
- Begin DoDot:1
- +5 IF $PIECE($GET(^BEHOAR(90460.05,IEN,0)),U,2)=FLG
- Begin DoDot:2
- +6 SET CNT=CNT+1
- +7 SET X=$PIECE($GET(^BEHOAR(90460.05,IEN,0)),U,3)
- +8 SET @RET@(CNT,0)=IEN_U_$PIECE($GET(^BEHOAR(90460.05,IEN,0)),U,1)_U_$SELECT(X="Y":1,X="N":0,1:0)
- End DoDot:2
- End DoDot:1
- +9 QUIT
- SNOMED(RET) ;EP List of snomed codes
- +1 NEW IEN,CNT,NAME
- +2 SET RET=$$TMPGBL()
- +3 SET CNT=0
- +4 SET NAME=""
- FOR
- SET NAME=$ORDER(^BEHOAR(90460.06,"B",NAME))
- IF NAME=""
- QUIT
- Begin DoDot:1
- +5 SET IEN=0
- FOR
- SET IEN=$ORDER(^BEHOAR(90460.06,"B",NAME,IEN))
- IF IEN=""
- QUIT
- Begin DoDot:2
- +6 IF +$PIECE($GET(^BEHOAR(90460.06,IEN,0)),U,4)
- QUIT
- +7 SET CNT=CNT+1
- +8 SET @RET@(CNT,0)=IEN_U_$PIECE($GET(^BEHOAR(90460.06,IEN,0)),U,1)_U_$PIECE($GET(^BEHOAR(90460.06,IEN,0)),U,2)
- End DoDot:2
- End DoDot:1
- +9 QUIT
- +10 ;Mark an allergy as entered in error
- +11 ;Input
- +12 ; IEN=Entry number in the 120.8 file
- +13 ; DFN=Patient's internal entry number
- +14 ; VAL=Array of values to be stored
- +15 ; ("GMRAERR")=Indicates this entry is to be marked EIE
- +16 ; ("GMRAERRBY")=User marking it (optional,will set to DUZ)
- +17 ; ("GMRAERRDT")=Date/time EIE (option,will set to NOW)
- +18 ; ("GMRAERCMTS")=N Comment lines for entering in error
- +19 ; ("GMRAERRCMTS",n)
- +20 ; OUPUT = error message or IEN of entry marked in error
- EIE(DATA,IEN,DFN,VAL) ;entered in error
- +1 NEW NOW,ORNODE,GMR0
- +2 SET GMR0=$PIECE($GET(^GMR(120.8,IEN,0)),U)
- SET DATA=""
- +3 IF '$LENGTH(GMR0)
- SET DATA="-1^Entry not found"
- QUIT
- +4 DO CKIN(DFN)
- +5 SET NOW=$$NOW^XLFDT
- +6 IF $GET(VAL("GMRAERRBY"))=""
- SET VAL("GMRAERRBY")=DUZ
- +7 IF $GET(VAL("GMRAERRDT"))=""
- SET VAL("GMRAERRDT")=NOW
- +8 SET ORNODE=$NAME(^TMP("GMRA",$JOB))
- +9 KILL @ORNODE
- MERGE @ORNODE=VAL
- +10 DO EIE^GMRAGUI1(IEN,DFN,ORNODE)
- +11 SET DATA=IEN
- +12 DO FIREEVT^BEHOART(DFN,2,IEN)
- +13 QUIT
- +14 ;Mark an allergy as inactivated
- +15 ;Input
- +16 ; IEN=Entry number in the 120.8 file
- +17 ; DFN=Patient's internal entry number
- +18 ; VAL=Array of values to be stored
- +19 ; ("GMRAINACT")=Date entry marked inactive (required)
- +20 ; ("GMRAINACBY")=User marking it (optional,will set to DUZ)
- +21 ; ("GMRAINWHY")=Reason marked inactive^comment if OTHER
- +22 ; OUPUT = error message or IEN of entry marked inactive
- INACT(DATA,IEN,DFN,VAL) ;inactive allergies
- +1 NEW X,Y,STOP,FNUM,AIEN,ERR,WHY,WHYIEN
- +2 IF IEN=""
- SET DATA="-1^Missing entry to inactivate"
- QUIT
- +3 DO CKIN(DFN)
- +4 SET STOP=0
- SET FNUM=120.899999912
- +5 SET AIEN="+1,"_IEN_","
- +6 SET FDA(120.899999912,AIEN,.01)=$GET(VAL("GMRAINACT"))
- +7 SET WHY=$GET(VAL("GMRAINWHY"))
- +8 SET WHYIEN=$$REASON(WHY)
- +9 IF WHYIEN
- SET FDA(120.899999912,AIEN,1)=$PIECE(WHYIEN,U,1)
- +10 IF $GET(VAL("GMRAINACBY"))=""
- SET VAL("GMRAINACBY")=DUZ
- +11 SET FDA(120.899999912,AIEN,2)=$GET(VAL("GMRAINACBY"))
- +12 IF $DATA(VAL("GMRACMTS"))
- DO GMRACMTS^BEHOART
- +13 DO UPDATE^DIE(,"FDA","IEN","ERR")
- +14 SET DATA=+IEN
- +15 DO FIREEVT^BEHOART(DFN,1,IEN)
- +16 KILL FDA,ERR
- +17 QUIT
- +18 ;Input
- +19 ; IEN=Entry number in the 120.8 file
- +20 ; DFN=Patient's internal entry number
- +21 ; VAL=Array of values to be stored
- +22 ; ("GMRAINRE")=Date/Time to reactivate (required to reactivate)
- +23 ; ("GMRAINREBY")=User reactivating (optional,will set to DUZ)
- +24 ; OUPUT = error message or IEN of entry marked inactive
- REACT(DATA,IEN,DFN,VAL) ;reactivate allergy
- +1 NEW X,Y,STOP,FNUM,AIEN,BIEN,ERR,SIEN,SIEN,MIEN,CANVER
- +2 IF IEN=""
- SET DATA="-1^Missing entry to reactivate"
- QUIT
- +3 DO CKIN(DFN)
- +4 SET STOP=0
- SET FNUM=120.899999912
- SET BIEN=IEN
- +5 SET SIEN=$ORDER(^GMR(120.8,IEN,9999999.12,$CHAR(0)),-1)
- +6 IF STOP!'SIEN
- SET DATA="-1^Unable to find entry to reactivate"
- QUIT
- +7 SET AIEN=SIEN_","_IEN_","
- +8 IF $GET(VAL("GMRAINREBY"))=""
- SET VAL("GMRAINREBY")=DUZ
- +9 IF $GET(VAL("GMRAINRE"))=""
- SET VAL("GMRAINRE")=$$NOW^XLFDT
- +10 ;S FDA(120.899999912,AIEN,.01)=$G(VAL("GMRAINACT"))
- +11 SET FDA(120.899999912,AIEN,3)=$GET(VAL("GMRAINRE"))
- +12 SET FDA(120.899999912,AIEN,4)=$GET(VAL("GMRAINREBY"))
- +13 DO UPDATE^DIE(,"FDA","IEN","ERR")
- +14 KILL FDA,ERR
- +15 ;Remove the verification, must be redone
- +16 SET AIEN=BIEN_","
- +17 SET FDA(120.8,AIEN,15)="@"
- +18 SET FDA(120.8,AIEN,19)="@"
- +19 SET FDA(120.8,AIEN,20)="@"
- +20 SET FDA(120.8,AIEN,21)="@"
- +21 DO FILE^DIE("","FDA","ERR")
- +22 SET DATA=IEN
- +23 DO FIREEVT^BEHOART(DFN,1,IEN)
- +24 ;Patch 11 changed to autosign
- +25 SET CANVER=$$HASKEY^BEHOUSCX("GMRA-ALLERGY VERIFY")
- +26 ;AUTOSIGN
- IF $$CANSIGN^BEHOART(DATA)
- DO SIGN^BEHOART(.SIG,DATA,CANVER)
- +27 ;D SNDALR^BEHOART(DATA,1)
- +28 KILL FDA,ERR
- +29 QUIT
- +30 ;
- +31 ;Add or release an allergy assessment of unassessable
- +32 ;Input
- +33 ; IEN=Entry in the 120.86 file (Blank if pt not in file)
- +34 ; DFN=Patient's internal entry number
- +35 ; VAL=array of values to be stored
- +36 ; ("GMRAACC")=Date entry marked unassessable
- +37 ; ("GMRAACRE")=Reason marked unassessable
- +38 ; ("GMRAACCBY")=User marking record as unassessable
- +39 ; OUPUT = error messagte or IEN of entry marked unassessable
- ASSESS(DATA,IEN,DFN,VAL) ;mark unassessible
- +1 NEW FNUM,NEW,X,ATIME,FDA,BIEN,AIEN,FDA2,AIEN2,WHY,WHYIEN,IEN,ACTION
- +2 SET FNUM=120.869999911
- +3 IF '$DATA(^GMR(120.86,DFN,0))
- Begin DoDot:1
- +4 SET AIEN="+1,"
- SET FDA(120.86,AIEN,.01)=DFN
- +5 SET IEN(1)=DFN
- +6 DO UPDATE^DIE(,"FDA","IEN","ERR")
- +7 IF 'IEN(1)
- SET DATA="-1^Unable to update allergy assessment"
- End DoDot:1
- +8 ;See if there are any earlier unable to assess nodes not closed out
- +9 SET ACTION=1
- +10 KILL FDA,IEN,ERR,AIEN
- +11 DO CKIN(DFN)
- +12 SET WHY=$GET(VAL("GMRAACRE"))
- +13 SET WHYIEN=$$REASON(WHY)
- +14 IF 'WHYIEN
- Begin DoDot:1
- +15 SET DATA="-1^A valid reason was not submitted"
- End DoDot:1
- QUIT
- +16 SET AIEN="+1,"_DFN_","
- +17 SET FDA(120.869999911,AIEN,.01)=VAL("GMRAACC")
- +18 SET FDA(120.869999911,AIEN,1)=$PIECE(WHYIEN,U,1)
- +19 IF $PIECE(WHYIEN,U,2)'=""
- SET FDA(120.869999911,AIEN,5)=$PIECE(WHYIEN,U,2)
- +20 IF $GET(VAL("GMRAACCBY"))=""
- SET VAL("GMRAACBY")=DUZ
- +21 SET FDA(120.869999911,AIEN,2)=VAL("GMRAACCBY")
- +22 DO UPDATE^DIE(,"FDA","IEN","ERR")
- +23 SET DATA=+$GET(IEN(1))
- +24 DO QUEUE^CIANBEVT("GMRA."_DFN,ACTION)
- +25 QUIT
- +26 ;Input
- +27 ; IEN=Entry in the 120.86 file (Blank if pt not in file)
- +28 ; DFN=Patient's internal entry number
- +29 ; VAL=array of values to be stored
- +30 ; ("GMRAACC")=Date entry marked unassessable
- +31 ; ("GMRAACCRE")="Date unassessible resolved"
- +32 ; ("GMRAACCBY")="User unmarking the unacessable"
- +33 ; OUPUT = error messagte or IEN of entry marked unassessable
- REASSESS(DATA,IEN,DFN,VAL) ;reactivate
- +1 ;Find node to close out
- +2 NEW AIEN,STOP,BIEN,ATIME
- +3 SET STOP=0
- +4 SET ATIME=9999999
- FOR
- SET ATIME=$ORDER(^GMR(120.86,DFN,9999999.11,"B",ATIME),-1)
- IF 'ATIME!(STOP=1)
- QUIT
- Begin DoDot:1
- +5 SET AIEN=""
- FOR
- SET AIEN=$ORDER(^GMR(120.86,DFN,9999999.11,"B",ATIME,AIEN))
- IF '+AIEN!(STOP=1)
- QUIT
- Begin DoDot:2
- +6 IF ATIME=VAL("GMRAACC")
- SET STOP=1
- +7 SET BIEN=AIEN_","_DFN_","
- +8 IF $GET(VAL("GMRAACRE"))=""
- SET VAL("GMRAACRE")=$$NOW^XLFDT
- +9 SET FDA(120.869999911,BIEN,3)=VAL("GMRAACRE")
- +10 IF $GET(VAL("GMRAACCBY"))=""
- SET VAL("GMRAACCBY")=DUZ
- +11 SET FDA(120.869999911,BIEN,4)=VAL("GMRAACCBY")
- +12 DO UPDATE^DIE(,"FDA","IEN","ERR")
- +13 IF '$DATA(ERR)
- SET DATA=IEN
- +14 KILL FDA,IEN,ERR
- +15 DO FIREEVT^BEHOART(DFN,2,"")
- End DoDot:2
- End DoDot:1
- +16 QUIT
- +17 ;See if there are any earlier unable to assess nodes not closed out
- +18 ;If so, close them out
- CKIN(DFN) ;
- +1 NEW ATIME,AIEN,BIEN,FDA2,IEN,ERR
- +2 SET ATIME=9999999
- FOR
- SET ATIME=$ORDER(^GMR(120.86,DFN,9999999.11,"B",ATIME),-1)
- IF ATIME=""
- QUIT
- Begin DoDot:1
- +3 SET BIEN=""
- FOR
- SET BIEN=$ORDER(^GMR(120.86,DFN,9999999.11,"B",ATIME,BIEN))
- IF BIEN=""
- QUIT
- Begin DoDot:2
- +4 IF $PIECE($GET(^GMR(120.86,DFN,9999999.11,BIEN,0)),U,4)=""
- Begin DoDot:3
- +5 SET AIEN=BIEN_","_DFN_","
- +6 SET FDA2(120.869999911,AIEN,3)=$$NOW^XLFDT
- +7 SET FDA2(120.869999911,AIEN,4)=DUZ
- +8 DO UPDATE^DIE(,"FDA2","IEN","ERR")
- +9 KILL FDA2,IEN,ERR
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +10 QUIT
- +11 ; Return IEN to BEH ALLERGY VALUES file
- REASON(VAL) ; EP -
- +1 NEW X,RET,COM
- +2 IF +VAL>0
- SET RET=+VAL
- +3 IF '$TEST
- SET X=$PIECE(VAL,U,2)
- SET RET=$ORDER(^BEHOAR(90460.05,"B",X,""))
- +4 SET COM=$PIECE(VAL,U,4)
- +5 IF COM'=""
- SET RET=RET_U_COM
- +6 QUIT RET
- +7 ;
- TMPGBL() KILL ^TMP("BEHOART",$JOB)
- QUIT $NAME(^($JOB))