BGOPROB1 ; IHS/BAO/TMD - pull patient PROBLEMS ;10-Jun-2016 14:18;MGH
;;1.1;BGO COMPONENTS;**13,14,20,21**;Mar 20, 2007;Build 1
;---------------------------------------------
; Edit a problem entry
; DFN = Patient IEN
; PRIEN = IEN of problem, null if new
; VIEN = Needed if asthma DX
; List(n)
; "P"[1] ^ SNOMED CT [2] ^ Descriptive CT [3] ^ Provider text [4] ^ Mapped ICD [5]
; ^ Location [6] ^ Date of Onset [7] ^ Status [8] ^ Class [9] ^ Problem # [10] ^ Priority [11]
; ^ Inpt Dx [12] ^ Laterality codes [13]
; "A"[1] ^ Classification [2] ^ Control [3] ^ V asthma IEN [4]
; "Q"[1] ^ Type [2] ^ Qualifier IEN [3] ^ Qual SNOMED [4] ^ By [5] ^ When [6] ^DEL [7]
EDIT(RET,DFN,PRIEN,VIEN,ARRAY) ;EP
N CLASS,DIEN,ONSET,NARR,LIEN,PRNUM,LOCN,DMOD,DENT,STAT,IMP,LAT,LATEXT
N FDA,IEN,FPNUM,FPIEN,FNUM,IENS,PRNEW,PRIOR,SNOCT,DESCT,XIEN,ERR
N ODIEN,ONARR,OCLASS,OSNOCT,ODESCT,OSTAT,OLDLAT,STAT2,SNODATA,VAPR,INPT
S FNUM=$$FNUM,RET="",ERR=0
S PRIEN=$G(PRIEN),VIEN=$G(VIEN)
S (DIEN,SNOCT)=""
I '+PRIEN S RET="-1^Problem IEN not sent" Q
S XIEN="" F S XIEN=$O(ARRAY(XIEN)) Q:XIEN=""!(ERR=1) D
.S INP=$G(ARRAY(XIEN))
.I $P(ARRAY(XIEN),U,1)="P" D PROB(.RET,INP)
.I $P(ARRAY(XIEN),U,1)="A" D ASTHMA(.RET,VIEN,INP,DIEN,DESCT)
.I $P(ARRAY(XIEN),U,1)="Q" D QUAL(.RET,INP)
Q
PROB(RET,INP) ;PROBLEM DATA
;Get old data to check what was changed
S ODIEN=$$GET1^DIQ(9000011,PRIEN,.01)
S ONARR=$$GET1^DIQ(9000011,PRIEN,.05)
S OSTAT=$$GET1^DIQ(9000011,PRIEN,.12,"I")
S OCLASS=$$GET1^DIQ(9000011,PRIEN,.04)
S OSNOCT=$$GET1^DIQ(9000011,PRIEN,80001)
S ODESCT=$$GET1^DIQ(9000011,PRIEN,80002)
S OLDLAT=$$GET1^DIQ(9000011,PRIEN,.22)
S DIEN=$P(INP,U,5)
S DIEN=$P($P(INP,U,5),"|",1)
S NARR=$P(INP,U,4)
S NARR=$TR(NARR,"^|","")
S ONSET=$$CVTDATE^BGOUTL($P(INP,U,7))
S CLASS=$P(INP,U,9)
S SNOCT=$P(INP,U,2)
;IHS/MSC/MGH Changed to new API
;S SNODATA=$$CONC^BSTSAPI(SNOCT_"^^^1")
S SNODATA=$$CONC^AUPNSICD(SNOCT_"^^^1")
S DIEN=$P($P(SNODATA,U,5),";",1)
I DIEN="" D
.I $$AICD^BGOUTL2 D
..S IMP=$$IMP^ICDEX("10D",DT)
..I IMP<DT!(IMP=DT) S DIEN="ZZZ.999"
..I IMP>DT S DIEN=".9999"
.E S DIEN=".9999"
I DIEN'["." S DIEN=DIEN_"."
S DESCT=$P(INP,U,3)
S STAT=$P(INP,U,8)
S PRNUM=$P(INP,U,10)
I '$D(^DPT(DFN,0)) S ERR=1,RET=$$ERR^BGOUTL(1001) Q
S PRIOR=$P(INP,U,11)
I $$AICD^BGOUTL2 S DIEN=$P($$ICDDX^ICDEX(DIEN,"","","E"),U,1)
E S DIEN=$P($$ICDDX^ICDCODE(DIEN),U,1)
I 'DIEN S ERR=1,RET=$$ERR^BGOUTL(1048) Q
;IHS/MSC/MGH update date modified to include time
S DMOD=$$NOW^XLFDT,DENT=$S(PRIEN:"",1:DT)
;Provider narrative is now provider text | descriptive SNOMED CT
;Patch 20 provider narrative is now provider text | descriptive SNOMED CT | Laterality
S LAT=$P(INP,U,13)
;Do not store unspecified laterality
I LAT="272741003|261665006"!(LAT="272741003|") S LAT=""
I LAT'="" D
.S LATEXT=$$CVPARM^BSTSMAP1("LAT",$P(LAT,"|",2))
.S NARR=NARR_"|"_DESCT_"|"_LATEXT
E S NARR=NARR_"|"_DESCT
I $L(NARR) D Q:RET
.S RET=$$FNDNARR^BGOUTL2(NARR)
.S:RET>0 NARR=RET,RET=""
S FPIEN=""
S IENS=PRIEN_","
S FDA=$NA(FDA(FNUM,IENS))
I DIEN'=ODIEN S @FDA@(.01)=DIEN
I DMOD'="" S @FDA@(.03)=DMOD
S @FDA@(.14)=DUZ
I CLASS'=OCLASS S @FDA@(.04)=CLASS
I NARR'=ONARR S @FDA@(.05)=NARR
S:PRNUM @FDA@(.07)=PRNUM
S PRNEW='PRIEN
I STAT="" S STAT=$P(SNODATA,U,9) ;Patch 20
S STAT2=$S(STAT="Chronic":"A",STAT="Inactive":"I",STAT="Sub-acute":"S",STAT="Episodic":"E",STAT="Social/Environmental":"O",STAT="Routine/Admin":"R",STAT="Admin":"R",1:"E")
I STAT2'=OSTAT D
.S @FDA@(.12)=STAT2
.I STAT2'="I" D
..S CLASS=""
..S @FDA@(.04)=""
I CLASS="P" S @FDA@(.12)="I"
S VAPR=$S(STAT2="A":"C",STAT2="S":"C",STAT2="O":"C",STAT2="E":"A",1:"")
S @FDA@(1.14)=VAPR
S @FDA@(.13)=ONSET
;IHS/MSC/MGH Entered by not part of editing a problem
;S @FDA@(1.03)=DUZ
I SNOCT'=OSNOCT S @FDA@(80001)=SNOCT
I DESCT'=ODESCT S @FDA@(80002)=DESCT
I (OLDLAT'=LAT)&($P(LAT,"|",2)'="") S @FDA@(.22)=LAT
S:LAT="" @FDA@(.22)="@"
D FILE^DIE("","FDA","ERR")
I ERR S RET=-1_U_"Unable to Edit problem"
Q:RET
D SETICD^BGOPROB1(.RES,PRIEN,$P(SNODATA,U,5),";")
D SETPRI^BGOPROB(,PRIEN_U_PRIOR)
S:'RET RET=PRIEN
D:RET>0 EVT(PRIEN,'PRNEW)
;Set inpt DX
N RES1,INPT
S INPT=$P(INP,U,12)
I INPT=1 S RES1="" D HOSP^BGOHOS(.RES1,PRIEN,VIEN)
Q
ASTHMA(RET,VIEN,INP,DIEN,SNOCT) ;ASTHMA DATA
N ACL,ASTHMA,RET2,AIEN,CONTROL,RET3,INP2,IENS,CODE
K FDA
S FNUM=$$FNUM,RET2=""
S IENS=PRIEN_","
S FDA=$NA(FDA(FNUM,IENS))
Q:'DFN
Q:'PRIEN
Q:'VIEN
S ACL=$P(INP,U,2)
Q:ACL=""
I DUZ("AG")="I" D
. S CODE=$$CODEC^ICDEX(80,DIEN)
. S ASTHMA=$$CHECK^BGOASLK(CODE,SNOCT)
. I ASTHMA=0 S @FDA@(.15)="@"
. I ASTHMA=1 D
..S ACL=$S(ACL="INTERMITTENT":1,ACL="MILD PERSISTENT":2,ACL="MODERATE PERSISTENT":3,ACL="SEVERE PERSISTENT":4,1:"")
..S @FDA@(.15)=ACL
..S RET2=$$UPDATE^BGOUTL(.FDA,,.IEN)
..I RET2 S ERR=1,RET=RET_U_"Error on Asthma Update"
..;Patch 6 check to see if its an asthma diagnosis
..I ASTHMA=1&(ACL="") S RET=RET_U_ASTHMA
..S CONTROL=$P(INP,U,3)
..S AIEN=$P(INP,U,4)
..I AIEN'="" D
...N X,Y
...S X=$O(^AUPNVAST("AD",VIEN,""))
...S Y=$O(^AUPNVAST("AD",AIEN,""))
...I X'=Y S AIEN=""
...E S AIEN=X
..I CONTROL="NONE RECORDED" S CONTROL=""
..I CONTROL'="" D
...S INP2=AIEN_U_VIEN_U_CONTROL
...D SET^BGOVAST(.RET3,INP2)
...I RET3 S RET=RET_U_RET3
Q
QUAL(RET,INP) ;QUALIFIERS
N FNUM,AIEN,QUAL,BY,WHEN,IEN,IEN2,TYPE,DEL,TYPE
K FDA
S TYPE=$P(INP,U,2)
S IEN=$P(INP,U,3)
S QUAL=$P(INP,U,4)
Q:QUAL=""
;S X=$$DESC^BSTSAPI(QUAL_"^^1")
;S QUAL=$P(X,U,1)
S BY=$P(INP,U,5)
I BY="" S BY=DUZ
S WHEN=$P(INP,U,6)
I WHEN="" S WHEN=$$NOW^XLFDT
S DEL=$P(INP,U,7)
Q:TYPE=""
; "S" for Severity, "F" is Finding Site, "C" is Clinical Course
S FNUM=$S(TYPE="S":9000011.13,TYPE="F":9000011.17,TYPE="C":9000011.18,1:"")
Q:FNUM=""
D CHECK(TYPE,.IEN)
I +IEN&(DEL=1) D
.D DELQ(.RET,PRIEN,IEN,TYPE)
.I TYPE="S" D DELQ(.RET,PRIEN,1,TYPE)
E D STORE
I TYPE="C" D DOUBLE(PRIEN) ;double check
Q
STORE ;Store the qualifier data
N AIEN,FDA,IEN2,ERR
I IEN="" S AIEN="+1,"_PRIEN_","
E S AIEN=IEN_","_PRIEN_","
S QUAL=$TR(QUAL," ","")
S FDA(FNUM,AIEN,.01)=QUAL
I TYPE="S" D
.S FDA(FNUM,AIEN,.02)=BY
.S FDA(FNUM,AIEN,.03)=WHEN
.I IEN'="" D
..S FDA(FNUM,AIEN,.04)=DUZ
..S FDA(FNUM,AIEN,.05)=$$NOW^XLFDT
D UPDATE^DIE(,"FDA","IEN2","ERR")
I $G(ERR("DIERR",1)) S RET=-ERR("DIERR",1)_U_ERR("DIERR",1,"TEXT",1)
Q
DELQ(RET,PRIEN,IEN,TYPE) ;Delete a qualifer
N ERR,DA,DIK,NODE
S ERR=""
S NODE=$S(TYPE="S":13,TYPE="F":17,TYPE="C":18)
S DA(1)=PRIEN,DA=IEN
S DIK="^AUPNPROB(DA(1),"_NODE_","
S:DA ERR=$$DELETE^BGOUTL(DIK,.DA)
I ERR'="" S RET=RET_"^"_ERR
Q
CHECK(TYPE,IEN) ;Check and see if there are already stored this type
;of qualifier. If not, add the standard SNOMED code
N NODE,QUAL
S NODE=$S(TYPE="S":13,TYPE="F":17,TYPE="C":18)
I '$D(^AUPNPROB(PRIEN,NODE,"B")) D
.S IEN=""
.S BY=DUZ
.S WHEN=$$NOW^XLFDT
.S QUAL=$S(TYPE="S":246112005,TYPE="F":363698007,TYPE="C":263502005)
.D STORE
E D
.I TYPE="S" D
..S IEN=1 S IEN=$O(^AUPNPROB(PRIEN,NODE,IEN))
..I +IEN=0 S IEN=""
Q
DOUBLE(PRIEN) ;Check if there are left-over items
N I,Z,ITEM,LCNT
S LCNT=0
S I=0 F S I=$O(^AUPNPROB(PRIEN,18,I)) Q:'+I D
.S LCNT=LCNT+1
.S ITEM(LCNT)=I
I LCNT=1 D
.S Z=$G(ITEM(LCNT))
.D DELQ(.RET,PRIEN,Z,"C")
Q
; Broadcast a problem event
EVT(PRIEN,OPR,X) ;EP
N DFN,DATA
S:'$D(X) X=$G(^AUPNPROB(PRIEN,0))
S DFN=$P(X,U,2),DATA=PRIEN_U_$G(CIA("UID"))_U_OPR
D:DFN BRDCAST^CIANBEVT("PCC."_DFN_".PRB",DATA)
Q
; Find family/personal history entry associated with problem
;MSC/IHS/MGH Family history removedin patch 6
FNDFP(PRIEN,FNUM) ;
N DFN,CLASS,DIEN,NIEN,DMOD,GBL,IEN,RET,X
S X=$G(^AUPNPROB(PRIEN,0)),DIEN=+X,DFN=$P(X,U,2),DMOD=$P(X,U,3),CLASS=$P(X,U,4),NIEN=$P(X,U,5)
S FNUM=$S(CLASS="P":9000013,1:0)
Q:'FNUM ""
S GBL=$$ROOT^DILFD(FNUM,,1)
Q:'$L(GBL) "" ;P8
S IEN=0,RET=""
F S IEN=$O(@GBL@("AC",DFN,IEN)) Q:'IEN D Q:RET
.S X=$G(@GBL@(IEN,0))
.I +X=DIEN,$P(X,U,2)=DFN,$P(X,U,3)\1=DMOD,$P(X,U,4)=NIEN S RET=IEN
Q RET
EDPROB(RET,DFN) ;Get active problems for a patient
N IEN,ITM,SNO,CNT,STATUS,STAT,CODE,ICD
S CNT=0,STATUS="ASEOR"
S RET=$$TMPGBL^BGOUTL
S STAT="" F S STAT=$O(^AUPNPROB("ACTIVE",DFN,STAT)) Q:STAT="" D
.S IEN="" F S IEN=+$O(^AUPNPROB("ACTIVE",DFN,STAT,IEN)) Q:'IEN D
..Q:STAT="D"
..Q:STATUS'[STAT
..S ITM=$$GET1^DIQ(9000011,IEN,.05),ICD=+$G(^AUPNPROB(IEN,0))
..I $$AICD^BGOUTL2 S CODE=$P($$ICDDX^ICDEX(ICD,$$NOW^XLFDT,"","I"),U,2)
..E S CODE=$$GET1^DIQ(80,ICD,.01)
..S SNO=$$GET1^DIQ(9000011,IEN,80001)
..Q:SNO=""
..S CNT=CNT+1
..S @RET@(CNT)=IEN_U_ITM_U_SNO_U_CODE
Q
INPT(RET,DFN) ;Return data for current or more recent inpt stay
N INPT,INVST,IEN,INVDT,PRIEN
;Is pt a current inpatient?
S RET=$$TMPGBL^BGOUTL
S INVST=""
S INPT=$G(^DPT(DFN,.105))
I +INPT D
.S INVST=$$GET1^DIQ(405,INPT,.27) ;Get visit
E D
.;Find most recent visit
.S INVDT=0 S INVDT=$O(^DGPM("APID",DFN,INVDT)) Q:'+INVDT D
..S IEN="" S IEN=$O(^DGPM("APID",DFN,INVDT,IEN)) Q:'+IEN D
...S INVST=$$GET1^DIQ(405,IEN,.27)
I INVST="" S @RET@(1)="No Inpt problems to return" Q
S PRIEN=""
F S PRIEN=$O(^AUPNPROB("AC",DFN,PRIEN)) Q:'PRIEN D
.;Check for which statuses to return
.S STAT=$P($G(^AUPNPROB(PRIEN,0)),U,12)
.Q:STAT="D"
.I $D(^AUPNPROB(PRIEN,14,"B",INVST)) D
..D GET^BGOPROB(.RET,DFN)
Q
GETONE(RET,PRIEN,PIP) ;Get ALl the data for one problem
N TYP,NUM,ACT,CPTYP,DFN,CNT,PER,CONCT
S RET=$$TMPGBL^BGOUTL
S PIP=$G(PIP)
S DFN=$$GET1^DIQ(9000011,PRIEN,.02,"I")
S TYP="ASEOIR",CPTYP="A",PER="P"
S NUM=9999999,ACT=1
I +PIP S ACT=2 ;P21
S CNT=0
D GET2^BGOPROB(.RET,PRIEN,DFN,TYP,CPTYP,NUM,ACT,PER,1)
Q
ADDICD(PRIEN) ;Get the additional ICD codes for a problem
N ICD,AIEN,CODE,STRING,RET
S ICD=0,RET=""
I '$D(^AUPNPROB(PRIEN,12)) Q ""
F S ICD=$O(^AUPNPROB(PRIEN,12,ICD)) Q:'+ICD D
.S AIEN=ICD_","_PRIEN_","
.S CODE=$$GET1^DIQ(9000011.12,AIEN,.01)
.I RET="" S RET=CODE
.E S RET=RET_"|"_CODE
Q RET
SETICD(RES,PRIEN,CODES,DEL) ;Store additional ICD codes for a problem
N AIEN,FDA,IEN2,ERR,FNUM,I,NODE
S FNUM=9000011.12
S NODE=12,RES=""
;First delete the existing additional ICD codes
I $D(^AUPNPROB(PRIEN,12)) D
.S IEN=0 F S IEN=$O(^AUPNPROB(PRIEN,12,IEN)) Q:'+IEN D
..N ERR,DA,DIK
..S ERR=""
..S DA(1)=PRIEN,DA=IEN
..S DIK="^AUPNPROB(DA(1),"_NODE_","
..S:DA ERR=$$DELETE^BGOUTL(DIK,.DA)
..I ERR'="" S RES=RES_"^"_ERR
;Next add in the codes
S X=$L(CODES,DEL)
F I=2:1:X D
.K FDA,AIEN,IEN2,ERR
.S AIEN="+1,"_PRIEN_","
.S FDA(FNUM,AIEN,.01)=$P(CODES,DEL,I)
.D UPDATE^DIE("E","FDA","IEN2","ERR")
.I $G(ERR("DIERR",1)) S RES=-ERR("DIERR",1)_U_ERR("DIERR",1,"TEXT",1)
Q RES
USED(PRIEN) ;Check to see if problem has been used as POV in the past
N PAST,NUM,X
S PAST=0,X=0
F S X=$O(^AUPNPROB(PRIEN,14,X)) Q:X=""!(PAST>0) D
.I $G(^AUPNPROB(PRIEN,14,X,0))'="" S PAST=PAST+1
S X=0
F S X=$O(^AUPNPROB(PRIEN,15,X)) Q:X=""!(PAST>0) D
.I $G(^AUPNPROB(PRIEN,15,X,0))'="" S PAST=PAST+1
Q PAST
CKID(RET,INP) ;EP
N DFN,SITE,PIEN,IEN,X1,X2
S DFN=+INP
S X1=$P(INP,U,2),X2=$P(X1,".",2),X1=$P(X1,".")
S SITE=+$P(INP,U,3)
S PIEN=$P(INP,U,4)
S IEN=$O(^AUPNPROB("AA",DFN,SITE," "_$E("000",1,4-$L(X1)-1)_X1_"."_X2_$E("00",1,3-$L(X2)-1),0))
I IEN,IEN'=PIEN S RET=$$ERR^BGOUTL(1047)
E S RET=$S(PIEN:IEN=PIEN,1:"")
Q
NEXTID(RET,DFN) ;EP
N ABBRV
S ABBRV=$P($G(^AUTTLOC(DUZ(2),0)),U,7),RET=""
I $L(ABBRV) D
.S RET=$E($O(^AUPNPROB("AA",DFN,DUZ(2),""),-1),2,999)\1+1
.S RET=ABBRV_"-"_$S(RET<1000:RET,1:"")
Q
LAT(PRIEN) ;EP
;IHS/MSC/MGH Check for laterality patch 20
N FLG,LAT,SEARCH,SNOMED,IN
S LAT=""
S LAT=$$GET1^DIQ(9000011,PRIEN,.22,"I")
I LAT'="" S FLG=1
E D
.S SEARCH="EHR IPL PROMPT FOR LATERALITY"
.S SNOMED=$$GET1^DIQ(9000011,PRIEN,80002)
.S IN=SNOMED_U_SEARCH_U_U_1
.S FLG=$$VSBTRMF^BSTSAPI(IN)
Q FLG_U_LAT
SETPRI(RET,INP) ;EP
N PRIEN,PRI,FDA,IEN,ADD
S PRIEN=+INP
S PRI=$P(INP,U,2)
I 'PRIEN S RET=$$ERR^BGOUTL(1008) Q
S IEN=$O(^BGOPROB("B",PRIEN,0))
S FDA=$NA(FDA(90362.22,$S(IEN:IEN_",",1:"+1,")))
S @FDA@(.01)="`"_PRIEN
S @FDA@(.02)=PRI
S RET=$$UPDATE^BGOUTL(.FDA,"E",.ADD)
I 'RET,'IEN S IEN=ADD(1)
S:'RET RET=IEN
Q
; Return file number
FNUM() Q 9000011
BGOPROB1 ; IHS/BAO/TMD - pull patient PROBLEMS ;10-Jun-2016 14:18;MGH
+1 ;;1.1;BGO COMPONENTS;**13,14,20,21**;Mar 20, 2007;Build 1
+2 ;---------------------------------------------
+3 ; Edit a problem entry
+4 ; DFN = Patient IEN
+5 ; PRIEN = IEN of problem, null if new
+6 ; VIEN = Needed if asthma DX
+7 ; List(n)
+8 ; "P"[1] ^ SNOMED CT [2] ^ Descriptive CT [3] ^ Provider text [4] ^ Mapped ICD [5]
+9 ; ^ Location [6] ^ Date of Onset [7] ^ Status [8] ^ Class [9] ^ Problem # [10] ^ Priority [11]
+10 ; ^ Inpt Dx [12] ^ Laterality codes [13]
+11 ; "A"[1] ^ Classification [2] ^ Control [3] ^ V asthma IEN [4]
+12 ; "Q"[1] ^ Type [2] ^ Qualifier IEN [3] ^ Qual SNOMED [4] ^ By [5] ^ When [6] ^DEL [7]
EDIT(RET,DFN,PRIEN,VIEN,ARRAY) ;EP
+1 NEW CLASS,DIEN,ONSET,NARR,LIEN,PRNUM,LOCN,DMOD,DENT,STAT,IMP,LAT,LATEXT
+2 NEW FDA,IEN,FPNUM,FPIEN,FNUM,IENS,PRNEW,PRIOR,SNOCT,DESCT,XIEN,ERR
+3 NEW ODIEN,ONARR,OCLASS,OSNOCT,ODESCT,OSTAT,OLDLAT,STAT2,SNODATA,VAPR,INPT
+4 SET FNUM=$$FNUM
SET RET=""
SET ERR=0
+5 SET PRIEN=$GET(PRIEN)
SET VIEN=$GET(VIEN)
+6 SET (DIEN,SNOCT)=""
+7 IF '+PRIEN
SET RET="-1^Problem IEN not sent"
QUIT
+8 SET XIEN=""
FOR
SET XIEN=$ORDER(ARRAY(XIEN))
IF XIEN=""!(ERR=1)
QUIT
Begin DoDot:1
+9 SET INP=$GET(ARRAY(XIEN))
+10 IF $PIECE(ARRAY(XIEN),U,1)="P"
DO PROB(.RET,INP)
+11 IF $PIECE(ARRAY(XIEN),U,1)="A"
DO ASTHMA(.RET,VIEN,INP,DIEN,DESCT)
+12 IF $PIECE(ARRAY(XIEN),U,1)="Q"
DO QUAL(.RET,INP)
End DoDot:1
+13 QUIT
PROB(RET,INP) ;PROBLEM DATA
+1 ;Get old data to check what was changed
+2 SET ODIEN=$$GET1^DIQ(9000011,PRIEN,.01)
+3 SET ONARR=$$GET1^DIQ(9000011,PRIEN,.05)
+4 SET OSTAT=$$GET1^DIQ(9000011,PRIEN,.12,"I")
+5 SET OCLASS=$$GET1^DIQ(9000011,PRIEN,.04)
+6 SET OSNOCT=$$GET1^DIQ(9000011,PRIEN,80001)
+7 SET ODESCT=$$GET1^DIQ(9000011,PRIEN,80002)
+8 SET OLDLAT=$$GET1^DIQ(9000011,PRIEN,.22)
+9 SET DIEN=$PIECE(INP,U,5)
+10 SET DIEN=$PIECE($PIECE(INP,U,5),"|",1)
+11 SET NARR=$PIECE(INP,U,4)
+12 SET NARR=$TRANSLATE(NARR,"^|","")
+13 SET ONSET=$$CVTDATE^BGOUTL($PIECE(INP,U,7))
+14 SET CLASS=$PIECE(INP,U,9)
+15 SET SNOCT=$PIECE(INP,U,2)
+16 ;IHS/MSC/MGH Changed to new API
+17 ;S SNODATA=$$CONC^BSTSAPI(SNOCT_"^^^1")
+18 SET SNODATA=$$CONC^AUPNSICD(SNOCT_"^^^1")
+19 SET DIEN=$PIECE($PIECE(SNODATA,U,5),";",1)
+20 IF DIEN=""
Begin DoDot:1
+21 IF $$AICD^BGOUTL2
Begin DoDot:2
+22 SET IMP=$$IMP^ICDEX("10D",DT)
+23 IF IMP<DT!(IMP=DT)
SET DIEN="ZZZ.999"
+24 IF IMP>DT
SET DIEN=".9999"
End DoDot:2
+25 IF '$TEST
SET DIEN=".9999"
End DoDot:1
+26 IF DIEN'["."
SET DIEN=DIEN_"."
+27 SET DESCT=$PIECE(INP,U,3)
+28 SET STAT=$PIECE(INP,U,8)
+29 SET PRNUM=$PIECE(INP,U,10)
+30 IF '$DATA(^DPT(DFN,0))
SET ERR=1
SET RET=$$ERR^BGOUTL(1001)
QUIT
+31 SET PRIOR=$PIECE(INP,U,11)
+32 IF $$AICD^BGOUTL2
SET DIEN=$PIECE($$ICDDX^ICDEX(DIEN,"","","E"),U,1)
+33 IF '$TEST
SET DIEN=$PIECE($$ICDDX^ICDCODE(DIEN),U,1)
+34 IF 'DIEN
SET ERR=1
SET RET=$$ERR^BGOUTL(1048)
QUIT
+35 ;IHS/MSC/MGH update date modified to include time
+36 SET DMOD=$$NOW^XLFDT
SET DENT=$SELECT(PRIEN:"",1:DT)
+37 ;Provider narrative is now provider text | descriptive SNOMED CT
+38 ;Patch 20 provider narrative is now provider text | descriptive SNOMED CT | Laterality
+39 SET LAT=$PIECE(INP,U,13)
+40 ;Do not store unspecified laterality
+41 IF LAT="272741003|261665006"!(LAT="272741003|")
SET LAT=""
+42 IF LAT'=""
Begin DoDot:1
+43 SET LATEXT=$$CVPARM^BSTSMAP1("LAT",$PIECE(LAT,"|",2))
+44 SET NARR=NARR_"|"_DESCT_"|"_LATEXT
End DoDot:1
+45 IF '$TEST
SET NARR=NARR_"|"_DESCT
+46 IF $LENGTH(NARR)
Begin DoDot:1
+47 SET RET=$$FNDNARR^BGOUTL2(NARR)
+48 IF RET>0
SET NARR=RET
SET RET=""
End DoDot:1
IF RET
QUIT
+49 SET FPIEN=""
+50 SET IENS=PRIEN_","
+51 SET FDA=$NAME(FDA(FNUM,IENS))
+52 IF DIEN'=ODIEN
SET @FDA@(.01)=DIEN
+53 IF DMOD'=""
SET @FDA@(.03)=DMOD
+54 SET @FDA@(.14)=DUZ
+55 IF CLASS'=OCLASS
SET @FDA@(.04)=CLASS
+56 IF NARR'=ONARR
SET @FDA@(.05)=NARR
+57 IF PRNUM
SET @FDA@(.07)=PRNUM
+58 SET PRNEW='PRIEN
+59 ;Patch 20
IF STAT=""
SET STAT=$PIECE(SNODATA,U,9)
+60 SET STAT2=$SELECT(STAT="Chronic":"A",STAT="Inactive":"I",STAT="Sub-acute":"S",STAT="Episodic":"E",STAT="Social/Environmental":"O",STAT="Routine/Admin":"R",STAT="Admin":"R",1:"E")
+61 IF STAT2'=OSTAT
Begin DoDot:1
+62 SET @FDA@(.12)=STAT2
+63 IF STAT2'="I"
Begin DoDot:2
+64 SET CLASS=""
+65 SET @FDA@(.04)=""
End DoDot:2
End DoDot:1
+66 IF CLASS="P"
SET @FDA@(.12)="I"
+67 SET VAPR=$SELECT(STAT2="A":"C",STAT2="S":"C",STAT2="O":"C",STAT2="E":"A",1:"")
+68 SET @FDA@(1.14)=VAPR
+69 SET @FDA@(.13)=ONSET
+70 ;IHS/MSC/MGH Entered by not part of editing a problem
+71 ;S @FDA@(1.03)=DUZ
+72 IF SNOCT'=OSNOCT
SET @FDA@(80001)=SNOCT
+73 IF DESCT'=ODESCT
SET @FDA@(80002)=DESCT
+74 IF (OLDLAT'=LAT)&($PIECE(LAT,"|",2)'="")
SET @FDA@(.22)=LAT
+75 IF LAT=""
SET @FDA@(.22)="@"
+76 DO FILE^DIE("","FDA","ERR")
+77 IF ERR
SET RET=-1_U_"Unable to Edit problem"
+78 IF RET
QUIT
+79 DO SETICD^BGOPROB1(.RES,PRIEN,$PIECE(SNODATA,U,5),";")
+80 DO SETPRI^BGOPROB(,PRIEN_U_PRIOR)
+81 IF 'RET
SET RET=PRIEN
+82 IF RET>0
DO EVT(PRIEN,'PRNEW)
+83 ;Set inpt DX
+84 NEW RES1,INPT
+85 SET INPT=$PIECE(INP,U,12)
+86 IF INPT=1
SET RES1=""
DO HOSP^BGOHOS(.RES1,PRIEN,VIEN)
+87 QUIT
ASTHMA(RET,VIEN,INP,DIEN,SNOCT) ;ASTHMA DATA
+1 NEW ACL,ASTHMA,RET2,AIEN,CONTROL,RET3,INP2,IENS,CODE
+2 KILL FDA
+3 SET FNUM=$$FNUM
SET RET2=""
+4 SET IENS=PRIEN_","
+5 SET FDA=$NAME(FDA(FNUM,IENS))
+6 IF 'DFN
QUIT
+7 IF 'PRIEN
QUIT
+8 IF 'VIEN
QUIT
+9 SET ACL=$PIECE(INP,U,2)
+10 IF ACL=""
QUIT
+11 IF DUZ("AG")="I"
Begin DoDot:1
+12 SET CODE=$$CODEC^ICDEX(80,DIEN)
+13 SET ASTHMA=$$CHECK^BGOASLK(CODE,SNOCT)
+14 IF ASTHMA=0
SET @FDA@(.15)="@"
+15 IF ASTHMA=1
Begin DoDot:2
+16 SET ACL=$SELECT(ACL="INTERMITTENT":1,ACL="MILD PERSISTENT":2,ACL="MODERATE PERSISTENT":3,ACL="SEVERE PERSISTENT":4,1:"")
+17 SET @FDA@(.15)=ACL
+18 SET RET2=$$UPDATE^BGOUTL(.FDA,,.IEN)
+19 IF RET2
SET ERR=1
SET RET=RET_U_"Error on Asthma Update"
+20 ;Patch 6 check to see if its an asthma diagnosis
+21 IF ASTHMA=1&(ACL="")
SET RET=RET_U_ASTHMA
+22 SET CONTROL=$PIECE(INP,U,3)
+23 SET AIEN=$PIECE(INP,U,4)
+24 IF AIEN'=""
Begin DoDot:3
+25 NEW X,Y
+26 SET X=$ORDER(^AUPNVAST("AD",VIEN,""))
+27 SET Y=$ORDER(^AUPNVAST("AD",AIEN,""))
+28 IF X'=Y
SET AIEN=""
+29 IF '$TEST
SET AIEN=X
End DoDot:3
+30 IF CONTROL="NONE RECORDED"
SET CONTROL=""
+31 IF CONTROL'=""
Begin DoDot:3
+32 SET INP2=AIEN_U_VIEN_U_CONTROL
+33 DO SET^BGOVAST(.RET3,INP2)
+34 IF RET3
SET RET=RET_U_RET3
End DoDot:3
End DoDot:2
End DoDot:1
+35 QUIT
QUAL(RET,INP) ;QUALIFIERS
+1 NEW FNUM,AIEN,QUAL,BY,WHEN,IEN,IEN2,TYPE,DEL,TYPE
+2 KILL FDA
+3 SET TYPE=$PIECE(INP,U,2)
+4 SET IEN=$PIECE(INP,U,3)
+5 SET QUAL=$PIECE(INP,U,4)
+6 IF QUAL=""
QUIT
+7 ;S X=$$DESC^BSTSAPI(QUAL_"^^1")
+8 ;S QUAL=$P(X,U,1)
+9 SET BY=$PIECE(INP,U,5)
+10 IF BY=""
SET BY=DUZ
+11 SET WHEN=$PIECE(INP,U,6)
+12 IF WHEN=""
SET WHEN=$$NOW^XLFDT
+13 SET DEL=$PIECE(INP,U,7)
+14 IF TYPE=""
QUIT
+15 ; "S" for Severity, "F" is Finding Site, "C" is Clinical Course
+16 SET FNUM=$SELECT(TYPE="S":9000011.13,TYPE="F":9000011.17,TYPE="C":9000011.18,1:"")
+17 IF FNUM=""
QUIT
+18 DO CHECK(TYPE,.IEN)
+19 IF +IEN&(DEL=1)
Begin DoDot:1
+20 DO DELQ(.RET,PRIEN,IEN,TYPE)
+21 IF TYPE="S"
DO DELQ(.RET,PRIEN,1,TYPE)
End DoDot:1
+22 IF '$TEST
DO STORE
+23 ;double check
IF TYPE="C"
DO DOUBLE(PRIEN)
+24 QUIT
STORE ;Store the qualifier data
+1 NEW AIEN,FDA,IEN2,ERR
+2 IF IEN=""
SET AIEN="+1,"_PRIEN_","
+3 IF '$TEST
SET AIEN=IEN_","_PRIEN_","
+4 SET QUAL=$TRANSLATE(QUAL," ","")
+5 SET FDA(FNUM,AIEN,.01)=QUAL
+6 IF TYPE="S"
Begin DoDot:1
+7 SET FDA(FNUM,AIEN,.02)=BY
+8 SET FDA(FNUM,AIEN,.03)=WHEN
+9 IF IEN'=""
Begin DoDot:2
+10 SET FDA(FNUM,AIEN,.04)=DUZ
+11 SET FDA(FNUM,AIEN,.05)=$$NOW^XLFDT
End DoDot:2
End DoDot:1
+12 DO UPDATE^DIE(,"FDA","IEN2","ERR")
+13 IF $GET(ERR("DIERR",1))
SET RET=-ERR("DIERR",1)_U_ERR("DIERR",1,"TEXT",1)
+14 QUIT
DELQ(RET,PRIEN,IEN,TYPE) ;Delete a qualifer
+1 NEW ERR,DA,DIK,NODE
+2 SET ERR=""
+3 SET NODE=$SELECT(TYPE="S":13,TYPE="F":17,TYPE="C":18)
+4 SET DA(1)=PRIEN
SET DA=IEN
+5 SET DIK="^AUPNPROB(DA(1),"_NODE_","
+6 IF DA
SET ERR=$$DELETE^BGOUTL(DIK,.DA)
+7 IF ERR'=""
SET RET=RET_"^"_ERR
+8 QUIT
CHECK(TYPE,IEN) ;Check and see if there are already stored this type
+1 ;of qualifier. If not, add the standard SNOMED code
+2 NEW NODE,QUAL
+3 SET NODE=$SELECT(TYPE="S":13,TYPE="F":17,TYPE="C":18)
+4 IF '$DATA(^AUPNPROB(PRIEN,NODE,"B"))
Begin DoDot:1
+5 SET IEN=""
+6 SET BY=DUZ
+7 SET WHEN=$$NOW^XLFDT
+8 SET QUAL=$SELECT(TYPE="S":246112005,TYPE="F":363698007,TYPE="C":263502005)
+9 DO STORE
End DoDot:1
+10 IF '$TEST
Begin DoDot:1
+11 IF TYPE="S"
Begin DoDot:2
+12 SET IEN=1
SET IEN=$ORDER(^AUPNPROB(PRIEN,NODE,IEN))
+13 IF +IEN=0
SET IEN=""
End DoDot:2
End DoDot:1
+14 QUIT
DOUBLE(PRIEN) ;Check if there are left-over items
+1 NEW I,Z,ITEM,LCNT
+2 SET LCNT=0
+3 SET I=0
FOR
SET I=$ORDER(^AUPNPROB(PRIEN,18,I))
IF '+I
QUIT
Begin DoDot:1
+4 SET LCNT=LCNT+1
+5 SET ITEM(LCNT)=I
End DoDot:1
+6 IF LCNT=1
Begin DoDot:1
+7 SET Z=$GET(ITEM(LCNT))
+8 DO DELQ(.RET,PRIEN,Z,"C")
End DoDot:1
+9 QUIT
+10 ; Broadcast a problem event
EVT(PRIEN,OPR,X) ;EP
+1 NEW DFN,DATA
+2 IF '$DATA(X)
SET X=$GET(^AUPNPROB(PRIEN,0))
+3 SET DFN=$PIECE(X,U,2)
SET DATA=PRIEN_U_$GET(CIA("UID"))_U_OPR
+4 IF DFN
DO BRDCAST^CIANBEVT("PCC."_DFN_".PRB",DATA)
+5 QUIT
+6 ; Find family/personal history entry associated with problem
+7 ;MSC/IHS/MGH Family history removedin patch 6
FNDFP(PRIEN,FNUM) ;
+1 NEW DFN,CLASS,DIEN,NIEN,DMOD,GBL,IEN,RET,X
+2 SET X=$GET(^AUPNPROB(PRIEN,0))
SET DIEN=+X
SET DFN=$PIECE(X,U,2)
SET DMOD=$PIECE(X,U,3)
SET CLASS=$PIECE(X,U,4)
SET NIEN=$PIECE(X,U,5)
+3 SET FNUM=$SELECT(CLASS="P":9000013,1:0)
+4 IF 'FNUM
QUIT ""
+5 SET GBL=$$ROOT^DILFD(FNUM,,1)
+6 ;P8
IF '$LENGTH(GBL)
QUIT ""
+7 SET IEN=0
SET RET=""
+8 FOR
SET IEN=$ORDER(@GBL@("AC",DFN,IEN))
IF 'IEN
QUIT
Begin DoDot:1
+9 SET X=$GET(@GBL@(IEN,0))
+10 IF +X=DIEN
IF $PIECE(X,U,2)=DFN
IF $PIECE(X,U,3)\1=DMOD
IF $PIECE(X,U,4)=NIEN
SET RET=IEN
End DoDot:1
IF RET
QUIT
+11 QUIT RET
EDPROB(RET,DFN) ;Get active problems for a patient
+1 NEW IEN,ITM,SNO,CNT,STATUS,STAT,CODE,ICD
+2 SET CNT=0
SET STATUS="ASEOR"
+3 SET RET=$$TMPGBL^BGOUTL
+4 SET STAT=""
FOR
SET STAT=$ORDER(^AUPNPROB("ACTIVE",DFN,STAT))
IF STAT=""
QUIT
Begin DoDot:1
+5 SET IEN=""
FOR
SET IEN=+$ORDER(^AUPNPROB("ACTIVE",DFN,STAT,IEN))
IF 'IEN
QUIT
Begin DoDot:2
+6 IF STAT="D"
QUIT
+7 IF STATUS'[STAT
QUIT
+8 SET ITM=$$GET1^DIQ(9000011,IEN,.05)
SET ICD=+$GET(^AUPNPROB(IEN,0))
+9 IF $$AICD^BGOUTL2
SET CODE=$PIECE($$ICDDX^ICDEX(ICD,$$NOW^XLFDT,"","I"),U,2)
+10 IF '$TEST
SET CODE=$$GET1^DIQ(80,ICD,.01)
+11 SET SNO=$$GET1^DIQ(9000011,IEN,80001)
+12 IF SNO=""
QUIT
+13 SET CNT=CNT+1
+14 SET @RET@(CNT)=IEN_U_ITM_U_SNO_U_CODE
End DoDot:2
End DoDot:1
+15 QUIT
INPT(RET,DFN) ;Return data for current or more recent inpt stay
+1 NEW INPT,INVST,IEN,INVDT,PRIEN
+2 ;Is pt a current inpatient?
+3 SET RET=$$TMPGBL^BGOUTL
+4 SET INVST=""
+5 SET INPT=$GET(^DPT(DFN,.105))
+6 IF +INPT
Begin DoDot:1
+7 ;Get visit
SET INVST=$$GET1^DIQ(405,INPT,.27)
End DoDot:1
+8 IF '$TEST
Begin DoDot:1
+9 ;Find most recent visit
+10 SET INVDT=0
SET INVDT=$ORDER(^DGPM("APID",DFN,INVDT))
IF '+INVDT
QUIT
Begin DoDot:2
+11 SET IEN=""
SET IEN=$ORDER(^DGPM("APID",DFN,INVDT,IEN))
IF '+IEN
QUIT
Begin DoDot:3
+12 SET INVST=$$GET1^DIQ(405,IEN,.27)
End DoDot:3
End DoDot:2
End DoDot:1
+13 IF INVST=""
SET @RET@(1)="No Inpt problems to return"
QUIT
+14 SET PRIEN=""
+15 FOR
SET PRIEN=$ORDER(^AUPNPROB("AC",DFN,PRIEN))
IF 'PRIEN
QUIT
Begin DoDot:1
+16 ;Check for which statuses to return
+17 SET STAT=$PIECE($GET(^AUPNPROB(PRIEN,0)),U,12)
+18 IF STAT="D"
QUIT
+19 IF $DATA(^AUPNPROB(PRIEN,14,"B",INVST))
Begin DoDot:2
+20 DO GET^BGOPROB(.RET,DFN)
End DoDot:2
End DoDot:1
+21 QUIT
GETONE(RET,PRIEN,PIP) ;Get ALl the data for one problem
+1 NEW TYP,NUM,ACT,CPTYP,DFN,CNT,PER,CONCT
+2 SET RET=$$TMPGBL^BGOUTL
+3 SET PIP=$GET(PIP)
+4 SET DFN=$$GET1^DIQ(9000011,PRIEN,.02,"I")
+5 SET TYP="ASEOIR"
SET CPTYP="A"
SET PER="P"
+6 SET NUM=9999999
SET ACT=1
+7 ;P21
IF +PIP
SET ACT=2
+8 SET CNT=0
+9 DO GET2^BGOPROB(.RET,PRIEN,DFN,TYP,CPTYP,NUM,ACT,PER,1)
+10 QUIT
ADDICD(PRIEN) ;Get the additional ICD codes for a problem
+1 NEW ICD,AIEN,CODE,STRING,RET
+2 SET ICD=0
SET RET=""
+3 IF '$DATA(^AUPNPROB(PRIEN,12))
QUIT ""
+4 FOR
SET ICD=$ORDER(^AUPNPROB(PRIEN,12,ICD))
IF '+ICD
QUIT
Begin DoDot:1
+5 SET AIEN=ICD_","_PRIEN_","
+6 SET CODE=$$GET1^DIQ(9000011.12,AIEN,.01)
+7 IF RET=""
SET RET=CODE
+8 IF '$TEST
SET RET=RET_"|"_CODE
End DoDot:1
+9 QUIT RET
SETICD(RES,PRIEN,CODES,DEL) ;Store additional ICD codes for a problem
+1 NEW AIEN,FDA,IEN2,ERR,FNUM,I,NODE
+2 SET FNUM=9000011.12
+3 SET NODE=12
SET RES=""
+4 ;First delete the existing additional ICD codes
+5 IF $DATA(^AUPNPROB(PRIEN,12))
Begin DoDot:1
+6 SET IEN=0
FOR
SET IEN=$ORDER(^AUPNPROB(PRIEN,12,IEN))
IF '+IEN
QUIT
Begin DoDot:2
+7 NEW ERR,DA,DIK
+8 SET ERR=""
+9 SET DA(1)=PRIEN
SET DA=IEN
+10 SET DIK="^AUPNPROB(DA(1),"_NODE_","
+11 IF DA
SET ERR=$$DELETE^BGOUTL(DIK,.DA)
+12 IF ERR'=""
SET RES=RES_"^"_ERR
End DoDot:2
End DoDot:1
+13 ;Next add in the codes
+14 SET X=$LENGTH(CODES,DEL)
+15 FOR I=2:1:X
Begin DoDot:1
+16 KILL FDA,AIEN,IEN2,ERR
+17 SET AIEN="+1,"_PRIEN_","
+18 SET FDA(FNUM,AIEN,.01)=$PIECE(CODES,DEL,I)
+19 DO UPDATE^DIE("E","FDA","IEN2","ERR")
+20 IF $GET(ERR("DIERR",1))
SET RES=-ERR("DIERR",1)_U_ERR("DIERR",1,"TEXT",1)
End DoDot:1
+21 QUIT RES
USED(PRIEN) ;Check to see if problem has been used as POV in the past
+1 NEW PAST,NUM,X
+2 SET PAST=0
SET X=0
+3 FOR
SET X=$ORDER(^AUPNPROB(PRIEN,14,X))
IF X=""!(PAST>0)
QUIT
Begin DoDot:1
+4 IF $GET(^AUPNPROB(PRIEN,14,X,0))'=""
SET PAST=PAST+1
End DoDot:1
+5 SET X=0
+6 FOR
SET X=$ORDER(^AUPNPROB(PRIEN,15,X))
IF X=""!(PAST>0)
QUIT
Begin DoDot:1
+7 IF $GET(^AUPNPROB(PRIEN,15,X,0))'=""
SET PAST=PAST+1
End DoDot:1
+8 QUIT PAST
CKID(RET,INP) ;EP
+1 NEW DFN,SITE,PIEN,IEN,X1,X2
+2 SET DFN=+INP
+3 SET X1=$PIECE(INP,U,2)
SET X2=$PIECE(X1,".",2)
SET X1=$PIECE(X1,".")
+4 SET SITE=+$PIECE(INP,U,3)
+5 SET PIEN=$PIECE(INP,U,4)
+6 SET IEN=$ORDER(^AUPNPROB("AA",DFN,SITE," "_$EXTRACT("000",1,4-$LENGTH(X1)-1)_X1_"."_X2_$EXTRACT("00",1,3-$LENGTH(X2)-1),0))
+7 IF IEN
IF IEN'=PIEN
SET RET=$$ERR^BGOUTL(1047)
+8 IF '$TEST
SET RET=$SELECT(PIEN:IEN=PIEN,1:"")
+9 QUIT
NEXTID(RET,DFN) ;EP
+1 NEW ABBRV
+2 SET ABBRV=$PIECE($GET(^AUTTLOC(DUZ(2),0)),U,7)
SET RET=""
+3 IF $LENGTH(ABBRV)
Begin DoDot:1
+4 SET RET=$EXTRACT($ORDER(^AUPNPROB("AA",DFN,DUZ(2),""),-1),2,999)\1+1
+5 SET RET=ABBRV_"-"_$SELECT(RET<1000:RET,1:"")
End DoDot:1
+6 QUIT
LAT(PRIEN) ;EP
+1 ;IHS/MSC/MGH Check for laterality patch 20
+2 NEW FLG,LAT,SEARCH,SNOMED,IN
+3 SET LAT=""
+4 SET LAT=$$GET1^DIQ(9000011,PRIEN,.22,"I")
+5 IF LAT'=""
SET FLG=1
+6 IF '$TEST
Begin DoDot:1
+7 SET SEARCH="EHR IPL PROMPT FOR LATERALITY"
+8 SET SNOMED=$$GET1^DIQ(9000011,PRIEN,80002)
+9 SET IN=SNOMED_U_SEARCH_U_U_1
+10 SET FLG=$$VSBTRMF^BSTSAPI(IN)
End DoDot:1
+11 QUIT FLG_U_LAT
SETPRI(RET,INP) ;EP
+1 NEW PRIEN,PRI,FDA,IEN,ADD
+2 SET PRIEN=+INP
+3 SET PRI=$PIECE(INP,U,2)
+4 IF 'PRIEN
SET RET=$$ERR^BGOUTL(1008)
QUIT
+5 SET IEN=$ORDER(^BGOPROB("B",PRIEN,0))
+6 SET FDA=$NAME(FDA(90362.22,$SELECT(IEN:IEN_",",1:"+1,")))
+7 SET @FDA@(.01)="`"_PRIEN
+8 SET @FDA@(.02)=PRI
+9 SET RET=$$UPDATE^BGOUTL(.FDA,"E",.ADD)
+10 IF 'RET
IF 'IEN
SET IEN=ADD(1)
+11 IF 'RET
SET RET=IEN
+12 QUIT
+13 ; Return file number
FNUM() QUIT 9000011
