BGOPROB ; IHS/BAO/TMD - pull patient PROBLEMS ;20-Jun-2017 15:25;DU
;;1.1;BGO COMPONENTS;**1,3,6,7,8,10,11,13,14,15,19,20,21,23**;Mar 20, 2007;Build 3
;---------------------------------------------
; Check for existence of problem id
; INP = Patient IEN ^ Problem ID ^ Site IEN ^ Problem IEN (optional)
; Patch 6 removed references to family history since they are in separate components
; Patch 6 also added ability to view and add classification for ashtma dx
; Patch 8 changes - problems are now logically deleted
; Patch 12 changes for AICD
; Patch 13 - changes were made now for SNOMED and Integrated problem list
; most sections have been radically changed
; Patch 20 - laterality added,routine status added
; Patch 21 - V OB note added
; Patch 23 - Fracture data added
CKID(RET,INP) ;EP
D CKID^BGOPROB1(.RET,INP)
Q
; Return next problem id
; DFN = Patient IEN
; .RET = Problem ID
NEXTID(RET,DFN) ;EP
D NEXTID^BGOPROB1(.RET,DFN)
Q
; Set priority
; INP = Problem IEN ^ Problem Priority
SETPRI(RET,INP) ;EP
D SETPRI^BGOPROB1(.RET,INP)
Q
; Get problem entries for a patient
; DFN = Patient IEN
; TYP= A(chronic),S(sub-acute),E(episodic),O(social/environmental),I(Inactive)
; If not sent, all active codes will be returned
; CPTYP= A All
; C Active
; L Last date
; NUM = Number of entries in V files to return
; ACT = Flag to indicate if care planning activities should be included
;-------------------------------------------------------------------------
;Array(n)="P" [1] ^ Problem Ien [2] ^ SNOMED CONCEPT ID [3] ^ SNOMED DESC ID[4] ^Number code [5] ^ Status [6]^ Onset [7] ^ Prov Narrative [8] ^ ICD [9] ^ Priority [10] ^ Class [11] ^ PIP [12] ^ Additional ICD [13]
; ^ inpt DX [14] ^ Outpt DX [15] ^ Ever used as POV [16] ^ Asthma DX [17] ^ Needs norm/abn [18] ^ Laterality flag [19] ^ Laterality [20]
;Array(n)="P1" [1] ^ Frequency [2] ^ Eye dx [3] ^last used as INPT [4]
;Array(n)="A" [1] ^ Classification [2] ^ Control [3] ^ V asthma IEN [4]
;Array(n)="N" [1] ^ Facility [2] ^ Note IEN [3] ^ Note Nmbr [4] ^ Text [5] ^ Status [6] ^ Date [7] ^ Author [8]
;Array(n)= "Q" [1] ^ TYPE [2] ^ IEN [3] ^ SNOMED [4] ^ Text [5]
;The problems are followed by the goals, pt.instructions, visit instructions and activities
;Array(n)=Type (G OR C) [1] ^ C Plan IEN [2] ^ Prob IEN [4] ^ Who entered [4] ^ Date Entered [5] ^ Status [6] ^ SIGN FLAG [7]
; =~t [1] ^ Text of the item [2]
;Array(n)="I" [1] ^ Instr IEN[2] ^ Prob IEN [3] ^ Vst Date [4] ^ Facility [5] ^ Prv IEN [6] ^ Location [7] ^ Entered Dt [8] ^ Visit IEN [9] ^V cat [10] ^ Locked [11] ^ Prov Name [12] ^ signed [13]
; =~t [1] ^Text of the item [2]
;Array(n)="O" [1] ^ OB IEN [2] ^ Prob IEN [3] ^ Vst Date [4] ^ Facility [5] ^ Prv IEN [6] ^ Location [7] ^ Entered Dt [8] ^Visit IEN [9] ^ V Cat [10] ^ ^ Locked [11] ^ Prov Name [12] ^ signed [13]
; =~t [1] ^Text of the item [2]
;Array(n)="T" [1] ^ TR IEN[2] ^ SNOMED term [3] ^ Prob IEN [4] ^ Vst Date [5] ^ Facility [6] ^ Prv IEN [7] ^ Location [8] ^ Entered Dt [9] ^ Visit IEN [10] ^ V Cat [11] ^Locked [12] ^ Prov name [13]
;Array(n)="S" [1] ^ SERVICE [2] ^Consult Date [3] ^ STAT [4]
;Array(n)="R" [1] ^ REFERRAL [2] ^ Referral Date [3] ^ Status [4]
;Array(n)="E" [1] ^ Topic [2] ^ Date [3]
;Array(n)="F" [1] ^ Fracture SNOMED ^ Fracture Text
GET(RET,DFN,TYP,CPTYP,NUM,ACT) ;EP
N PRIEN,CNT,PER
S PER=""
; Default values if not passed in
I $G(TYP)="" S TYP="ASEOR"
I $G(CPTYP)="" S CPTYP="L"
;For Visit instructions and treatments, the default is the latest visit
I $G(NUM)="" S NUM=1
S ACT=$G(ACT)
S RET=$$TMPGBL^BGOUTL
S (PRIEN,CNT)=0
F S PRIEN=$O(^AUPNPROB("AC",DFN,PRIEN)) Q:'PRIEN D
.D GET2(.RET,PRIEN,DFN,TYP,CPTYP,NUM,ACT,PER)
Q
GET2(RET,PRIEN,DFN,TYP,CPTYP,NUM,ACT,PER,ONE) ;Get information for one problem
N REC,NOTES,POVIEN,ICD,ICDNAME,MODDT,CLS,FAC,FACIEN,FACAB,PIP,INPT,INPTDX,OUTPT,OUTPTDX
N PNAR,DENT,NMBCOD,STAT,ONSET,PRI,CLASS,PRV,ARRAY,PHXCNT,SNOMED,I,EVNDT,NORMAL,FLTR,FRACTURE,FXLST
N CONCT,DESCT,CT,CT2,PTEXT,REC8,IN,OUT,ARR,STAT2,XICD,POVEVER,ASM,VIEN,INJSTR,DEFST
I '$D(CNT) S CNT=0
S PER=$G(PER),ONE=$G(ONE),FRACTURE=""
S (INPTDX,OUTPTDX)="",POVEVER=0
S REC=$G(^AUPNPROB(PRIEN,0))
S REC8=$G(^AUPNPROB(PRIEN,800))
Q:$P(REC,U,2)'=DFN
S POVIEN=$P(REC,U)
Q:POVIEN=""
;IHS/MSC/MGH Patch 12 changes
S EVNDT=$$FMTDATE^BGOUTL($P($G(^AUPNPROB(PRIEN,0)),U,8))
S ICD=$P($$ICDDX^ICDEX(POVIEN,EVNDT,"","I"),U,2)
Q:ICD=""
;Check for which statuses to return
S STAT=$P(REC,U,12)
Q:STAT="D"
;Q:TYP'[STAT
I STAT="" S STAT="I"
I STAT'="I",TYP'[STAT Q ;P20 Inactive/Phx Handled Below
S STAT2=$$GET1^DIQ(9000011,PRIEN,.12)
S CONCT=$P(REC8,U,1)
S DESCT=$P(REC8,U,2)
;MSC/MGH Patch 23
S SNODATA=$$CONC^BSTSAPI(CONCT_"^^^1")
S FRACTURE=$P(SNODATA,U,10)
S FXLST=$P(SNODATA,U,11)
;MSC/MGH Patch 20
S DEFST=""
I ONE=1 D
.;S SNODATA=$$CONC^AUPNSICD(CONCT_"^^^1")
.S DEFST=$P(SNODATA,U,9)
.I STAT="I"&(DEFST="") S DEFST="Episodic"
S CLS=$P(REC,U,4)
S:CLS="" CLS="U"
;Q:'+ONE&(STAT="I")&(((CLS'="P")&(PER="P"))!((CLS="P")&(PER'="P"))) ;P20
S FLTR=0 D Q:FLTR
. I +ONE Q ;Requested specific problem
. I STAT'="I" Q ;Not inactive or PHx
. I CLS'="P",TYP'["I" S FLTR=1 Q ;Inactive, but don't want
. I CLS="P",TYP'["P" S FLTR=1 Q ;PHx, but don't want
I CLS="P" S ARRAY(ICD)=""
S PNAR=$$GET1^DIQ(9000011,PRIEN,.05)
Q:PNAR=""
S FACIEN=+$P(REC,U,6)
S FACAB=$P($G(^AUTTLOC(FACIEN,0)),U,7),FAC=$P($G(^(0)),U,10)
I $G(DUZ("AG"))'="I" S:'$L(FAC) FAC=999999 ;P6
Q:FAC'?6N
S NMBCOD=$P(REC,U,7)
Q:'NMBCOD
I FACAB="" S FACAB="ZZZZ"
S:$L(FACAB) NMBCOD=FACAB_"-"_NMBCOD
S PRV=$P($G(^AUPNPROB(PRIEN,1)),U,4)
S:PRV PRV=$P($G(^VA(200,+PRV,0)),U)
S ONSET=$$FMTDATE^BGOUTL($P(REC,U,13))
S PIP=$P($G(^AUPNPROB(PRIEN,0)),U,19)
S PRI=$O(^BGOPROB("B",PRIEN,0))
S:PRI PRI=$P($G(^BGOPROB(PRI,0)),U,2)
S XICD=$$ADDICD^BGOPROB1(PRIEN)
N X,VAR
S POVEVER=$$USED^BGOPROB1(PRIEN) ;P14
S VAR=$$GETVAR^CIAVMEVT("ENCOUNTER.ID.ALTERNATEVISITID",,"CONTEXT.ENCOUNTER")
S VIEN=""
I VAR'="" D
.S VIEN=$$VSTR2VIS^BEHOENCX(DFN,VAR)
.Q:VIEN<1
.I $P($G(^AUPNVSIT(VIEN,0)),U,7)="H"!($P($G(^AUPNVSIT(VIEN,0)),U,7)="O") D
..S INPT="" S INPT=$O(^AUPNPROB(PRIEN,15,"B",VIEN,INPT))
..I +INPT S INPTDX=1
.E D
..S OUTPT="" S OUTPT=$O(^AUPNPROB(PRIEN,14,"B",VIEN,OUTPT))
..I +OUTPT D
...N VPOV,FOUND
...S FOUND=0
...S VPOV=0 F S VPOV=$O(^AUPNVPOV("AD",VIEN,VPOV)) Q:VPOV=""!(FOUND=1) D
....I $P($G(^AUPNVPOV(VPOV,0)),U,16)=PRIEN D
.....S OUTPTDX=VPOV
.....S FOUND=1
S NORMAL=""
I DESCT'="" D QUALLK^BGOVPOV1(.NORMAL,DESCT,"N")
S ASM=""
D CHKASM^BGOASLK(.ASM,ICD,DESCT)
S LAT=$$LAT^BGOPROB1(PRIEN) ;IHS/MSC/MGH Patch 20 for laterality
S CNT=CNT+1
;S @RET@(CNT)=NMBCOD_U_DFN_U_ICD_U_MODDT_U_CLS_U_PNAR_U_DENT_U_STAT_U_ONSET_U_PRIEN_U_NOTES_U_POVIEN_U_ICDNAME_U_PRV_U_FACIEN_U_PRI_U_CLASS
S @RET@(CNT)="P"_U_PRIEN_U_CONCT_U_DESCT_U_NMBCOD_U_STAT2_U_ONSET_U_PNAR_U_ICD_U_PRI_U_CLS_U_PIP_U_XICD_U_INPTDX_U_OUTPTDX_U_POVEVER_U_ASM_U_NORMAL_U_LAT_U_DEFST
;Patch 20 added for sorting
D P1^BGOPROB2(.RET,.CNT,DFN,PRIEN,DESCT)
;MSC/MGH Patch 23
I FRACTURE'="" D
.S CNT=CNT+1
.S @RET@(CNT)="F"_U_FRACTURE_U_FXLST
;Return qualifiers for this problem
N QUAL,QNODE,SNO,TXT,X,QPRV
S TXT=""
N YQ,Z
F YQ=13,17,18 D
.S QUAL=1 F S QUAL=$O(^AUPNPROB(PRIEN,YQ,QUAL)) Q:'+QUAL D
..S CNT=CNT+1
..S QNODE=$G(^AUPNPROB(PRIEN,YQ,QUAL,0))
..S SNO=$P(QNODE,U,1)
..S X=$$CONC^BSTSAPI(SNO_"^^^1")
..I $P(X,U,1)'="" S TXT=$P(X,U,4)
..S Z=$S(YQ=13:"S",YQ=17:"F",YQ=18:"C")
..S QPRV=$P(QNODE,U,2)
..I QPRV'="" S QPRV=$P($G(^VA(200,QPRV,0)),U)
..;S @RET@(CNT)="Q"_U_Z_U_QUAL_U_SNO_U_TXT_U_$P(QNODE,U,2)_U_$P(QNODE,U,3)
..S @RET@(CNT)="Q"_U_Z_U_QUAL_U_SNO_U_TXT_U_QPRV_U_$$FMTDATE^BGOUTL($P(QNODE,U,3))
;IHS/MSC/MGH Patch 15 moved to new routine
;Get the asthm control information
S CONTROL=$$CLASS^BGOPROB2(REC,DFN,ASM)
I CONTROL'="" D
.S CNT=CNT+1
.S @RET@(CNT)=CONTROL
;Return notes for this problem
S NOTES=""
D NOTES^BGOPRBN(.NOTES,PRIEN,1)
S I="" F S I=$O(NOTES(I)) Q:I="" D
.S CNT=CNT+1
.S @RET@(CNT)="N"_U_$G(NOTES(I))
S INJSTR=$$INJCHK^BGOPROB2(PRIEN,VIEN)
I INJSTR'="" D
.S CNT=CNT+1
.S @RET@(CNT)=INJSTR
;Return goals, care plans, visit instructions and treatments, consults, referrals and education topics
I +ACT>0 D
.D GET^BGOCPLAN(.RET,PRIEN,DFN,"G",CPTYP,.CNT)
.D GET^BGOCPLAN(.RET,PRIEN,DFN,"P",CPTYP,.CNT)
.D GET^BGOVVI(.RET,DFN,PRIEN,NUM,.CNT)
.D GET^BGOVTR(.RET,DFN,PRIEN,NUM,.CNT)
.I ACT=2 D GET^BGOVOB(.RET,DFN,PRIEN,NUM,.CNT)
.D GETCON^BGOVTR(.RET,DFN,PRIEN,NUM,.CNT)
.D GETREF^BGOVTR(.RET,DFN,PRIEN,NUM,.CNT)
.D GETEDU^BGOVTR(.RET,DFN,PRIEN,NUM,.CNT)
Q
; Delete a problem entry
; PRIEN = Problem IEN ^ TYPE ^ DELETE REASON ^ OTHER^PROB ID
DEL(RET,PRIEN) ;EP
D DEL^BGOPROB3(.RET,PRIEN)
Q
; Add 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]
; ^ INP 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] ^ Delete [7]
; SPEC = Special conditions
; PIP = Prenatal Problem sent from PIP
SET(RET,DFN,PRIEN,VIEN,ARRAY,SPEC,PIP) ;EP
N CLASS,DIEN,ONSET,NARR,LIEN,PRNUM,LOCN,DMOD,DENT,VAPR,INP,INPT,SNODATA
N FDA,IEN,FPNUM,FPIEN,FNUM,IENS,PRNEW,PRIOR,SNOCT,DESCT,XIEN,ERR,IMP,INDIEN
S SPEC=$G(SPEC),PIP=$G(PIP)
S FNUM=$$FNUM,RET="",ERR=0
S (DIEN,SNOCT)=""
S PRIEN=$G(PRIEN),VIEN=$G(VIEN)
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,SPEC,PIP)
.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,SPEC,PIP) ;PROBLEM DATA
N X,INDIEN,LAT,LATEXT
S INDIEN=$P($P(INP,U,5),"|",1)
S NARR=$P(INP,U,4)
S NARR=$TR(NARR,"^|","")
S LIEN=$P(INP,U,6)
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-P14
;S SNODATA=$$CONC^BSTSAPI(SNOCT_"^^^1")
S SNODATA=$$CONC^AUPNSICD(SNOCT_"^^^1")
;IHS/MSC/MGH changed to handle special cases p14
I +SPEC S DIEN=INDIEN
E S DIEN=$P($P(SNODATA,U,5),";",1)
;I ((DIEN="")!(DIEN=".9999")!(DIEN="ZZZ.999"))&(INDIEN'="") S DIEN=INDIEN
I DIEN="" D
.;Patch 14 check for which undefined code to use
.S IMP=$$IMP^ICDEX("10D",DT)
.I IMP'>$$NOW^XLFDT S DIEN="ZZZ.999"
.I IMP>$$NOW^XLFDT S DIEN=".9999"
I DIEN'["." S DIEN=DIEN_"."
S DESCT=$P(INP,U,3)
;I CLASS="P"&(DUZ("AG")'="I") S CLASS="I"
S STAT=$P(INP,U,8)
;MSC/MGH Store default status from lookup patch 20
I STAT="" S STAT=$P(SNODATA,U,9)
I STAT="" S STAT="Episodic"
S STAT=$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")
S VAPR=$S(STAT="A":"C",STAT="S":"C",STAT="O":"C",STAT="E":"A",STAT="R":"C",1:"")
I '$D(^DPT(DFN,0)) S ERR=1,RET=$$ERR^BGOUTL(1001) Q
S PRNUM=$P(INP,U,10)
S PRNEW='PRIEN
S PRIOR=$P(INP,U,11)
S DIEN=$P($$ICDDX^ICDEX(DIEN,"","","E"),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)
I 'LIEN S ERR=1,RET=$$ERR^BGOUTL(1049) Q
;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=""
I PRIEN D
.S IENS=PRIEN_","
E D
.S:'PRNUM PRNUM=1+$E($O(^AUPNPROB("AA",DFN,LIEN,""),-1),2,99)
.S (FPIEN,FPNUM)=""
.S IENS="+1,"
S FDA=$NA(FDA(FNUM,IENS))
S @FDA@(.01)=DIEN
S:PRNEW @FDA@(.02)=DFN
S @FDA@(.03)=DMOD
S @FDA@(.14)=DUZ
I CLASS="P" S STAT="I"
S @FDA@(.04)=$S($L(CLASS):CLASS,1:"@")
S @FDA@(.05)=$S(NARR:NARR,1:"@")
S:PRNEW @FDA@(.06)=LIEN
S:PRNUM @FDA@(.07)=PRNUM
S:PRNEW @FDA@(.08)=DENT
S @FDA@(1.03)=DUZ
S @FDA@(.12)=STAT
S @FDA@(.13)=ONSET
S:PRNEW @FDA@(1.04)=DUZ
S @FDA@(1.14)=VAPR
S @FDA@(80001)=SNOCT
S @FDA@(80002)=DESCT
I $P(LAT,"|",2)'="" S @FDA@(.22)=LAT ;Patch 20
S RET=$$UPDATE^BGOUTL(.FDA,,.IEN)
Q:RET
S:'PRIEN PRIEN=IEN(1)
D SETPRI(,PRIEN_U_PRIOR)
;IHS/MSC/MGH Set prenatal PIP if called from CVG Patch 20
I +PIP D
.I $$TEST^CIAUOS("SET^BJPNAPIS") S RET=$$SET^BJPNAPIS(PRIEN) Q:RET ;Set Prenatal PIP entry
S:'RET RET=PRIEN
D:RET>0 EVT(PRIEN,'PRNEW)
N RES
;Set any extra ICD codes
D SETICD^BGOPROB1(.RES,PRIEN,$P(SNODATA,U,5),";")
;Set inpt DX
N RES1
S INPT=$P(INP,U,12)
I INPT=1 S RES1="" D HOSP^BGOHOS(.RES1,PRIEN,VIEN)
;S:FPIEN RET=$$DELETE^BGOUTL(FPNUM,FPIEN)
;S:'RET&(DUZ("AG")="I") RET=$$SETFP(PRIEN)
Q
ASTHMA(RET,VIEN,INP,DIEN,DESCT) ;ASTHMA DATA
D ASTHMA^BGOPROB3(.RET,VIEN,INP,DIEN,DESCT)
Q
QUAL(RET,INP) ;QUALIFIERS
D QUAL^BGOPROB1(.RET,INP)
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
; Return file number
FNUM() Q 9000011
BGOPROB ; IHS/BAO/TMD - pull patient PROBLEMS ;20-Jun-2017 15:25;DU
+1 ;;1.1;BGO COMPONENTS;**1,3,6,7,8,10,11,13,14,15,19,20,21,23**;Mar 20, 2007;Build 3
+2 ;---------------------------------------------
+3 ; Check for existence of problem id
+4 ; INP = Patient IEN ^ Problem ID ^ Site IEN ^ Problem IEN (optional)
+5 ; Patch 6 removed references to family history since they are in separate components
+6 ; Patch 6 also added ability to view and add classification for ashtma dx
+7 ; Patch 8 changes - problems are now logically deleted
+8 ; Patch 12 changes for AICD
+9 ; Patch 13 - changes were made now for SNOMED and Integrated problem list
+10 ; most sections have been radically changed
+11 ; Patch 20 - laterality added,routine status added
+12 ; Patch 21 - V OB note added
+13 ; Patch 23 - Fracture data added
CKID(RET,INP) ;EP
+1 DO CKID^BGOPROB1(.RET,INP)
+2 QUIT
+3 ; Return next problem id
+4 ; DFN = Patient IEN
+5 ; .RET = Problem ID
NEXTID(RET,DFN) ;EP
+1 DO NEXTID^BGOPROB1(.RET,DFN)
+2 QUIT
+3 ; Set priority
+4 ; INP = Problem IEN ^ Problem Priority
SETPRI(RET,INP) ;EP
+1 DO SETPRI^BGOPROB1(.RET,INP)
+2 QUIT
+3 ; Get problem entries for a patient
+4 ; DFN = Patient IEN
+5 ; TYP= A(chronic),S(sub-acute),E(episodic),O(social/environmental),I(Inactive)
+6 ; If not sent, all active codes will be returned
+7 ; CPTYP= A All
+8 ; C Active
+9 ; L Last date
+10 ; NUM = Number of entries in V files to return
+11 ; ACT = Flag to indicate if care planning activities should be included
+12 ;-------------------------------------------------------------------------
+13 ;Array(n)="P" [1] ^ Problem Ien [2] ^ SNOMED CONCEPT ID [3] ^ SNOMED DESC ID[4] ^Number code [5] ^ Status [6]^ Onset [7] ^ Prov Narrative [8] ^ ICD [9] ^ Priority [10] ^ Class [11] ^ PIP [12] ^ Additional ICD [13]
+14 ; ^ inpt DX [14] ^ Outpt DX [15] ^ Ever used as POV [16] ^ Asthma DX [17] ^ Needs norm/abn [18] ^ Laterality flag [19] ^ Laterality [20]
+15 ;Array(n)="P1" [1] ^ Frequency [2] ^ Eye dx [3] ^last used as INPT [4]
+16 ;Array(n)="A" [1] ^ Classification [2] ^ Control [3] ^ V asthma IEN [4]
+17 ;Array(n)="N" [1] ^ Facility [2] ^ Note IEN [3] ^ Note Nmbr [4] ^ Text [5] ^ Status [6] ^ Date [7] ^ Author [8]
+18 ;Array(n)= "Q" [1] ^ TYPE [2] ^ IEN [3] ^ SNOMED [4] ^ Text [5]
+19 ;The problems are followed by the goals, pt.instructions, visit instructions and activities
+20 ;Array(n)=Type (G OR C) [1] ^ C Plan IEN [2] ^ Prob IEN [4] ^ Who entered [4] ^ Date Entered [5] ^ Status [6] ^ SIGN FLAG [7]
+21 ; =~t [1] ^ Text of the item [2]
+22 ;Array(n)="I" [1] ^ Instr IEN[2] ^ Prob IEN [3] ^ Vst Date [4] ^ Facility [5] ^ Prv IEN [6] ^ Location [7] ^ Entered Dt [8] ^ Visit IEN [9] ^V cat [10] ^ Locked [11] ^ Prov Name [12] ^ signed [13]
+23 ; =~t [1] ^Text of the item [2]
+24 ;Array(n)="O" [1] ^ OB IEN [2] ^ Prob IEN [3] ^ Vst Date [4] ^ Facility [5] ^ Prv IEN [6] ^ Location [7] ^ Entered Dt [8] ^Visit IEN [9] ^ V Cat [10] ^ ^ Locked [11] ^ Prov Name [12] ^ signed [13]
+25 ; =~t [1] ^Text of the item [2]
+26 ;Array(n)="T" [1] ^ TR IEN[2] ^ SNOMED term [3] ^ Prob IEN [4] ^ Vst Date [5] ^ Facility [6] ^ Prv IEN [7] ^ Location [8] ^ Entered Dt [9] ^ Visit IEN [10] ^ V Cat [11] ^Locked [12] ^ Prov name [13]
+27 ;Array(n)="S" [1] ^ SERVICE [2] ^Consult Date [3] ^ STAT [4]
+28 ;Array(n)="R" [1] ^ REFERRAL [2] ^ Referral Date [3] ^ Status [4]
+29 ;Array(n)="E" [1] ^ Topic [2] ^ Date [3]
+30 ;Array(n)="F" [1] ^ Fracture SNOMED ^ Fracture Text
GET(RET,DFN,TYP,CPTYP,NUM,ACT) ;EP
+1 NEW PRIEN,CNT,PER
+2 SET PER=""
+3 ; Default values if not passed in
+4 IF $GET(TYP)=""
SET TYP="ASEOR"
+5 IF $GET(CPTYP)=""
SET CPTYP="L"
+6 ;For Visit instructions and treatments, the default is the latest visit
+7 IF $GET(NUM)=""
SET NUM=1
+8 SET ACT=$GET(ACT)
+9 SET RET=$$TMPGBL^BGOUTL
+10 SET (PRIEN,CNT)=0
+11 FOR
SET PRIEN=$ORDER(^AUPNPROB("AC",DFN,PRIEN))
IF 'PRIEN
QUIT
Begin DoDot:1
+12 DO GET2(.RET,PRIEN,DFN,TYP,CPTYP,NUM,ACT,PER)
End DoDot:1
+13 QUIT
GET2(RET,PRIEN,DFN,TYP,CPTYP,NUM,ACT,PER,ONE) ;Get information for one problem
+1 NEW REC,NOTES,POVIEN,ICD,ICDNAME,MODDT,CLS,FAC,FACIEN,FACAB,PIP,INPT,INPTDX,OUTPT,OUTPTDX
+2 NEW PNAR,DENT,NMBCOD,STAT,ONSET,PRI,CLASS,PRV,ARRAY,PHXCNT,SNOMED,I,EVNDT,NORMAL,FLTR,FRACTURE,FXLST
+3 NEW CONCT,DESCT,CT,CT2,PTEXT,REC8,IN,OUT,ARR,STAT2,XICD,POVEVER,ASM,VIEN,INJSTR,DEFST
+4 IF '$DATA(CNT)
SET CNT=0
+5 SET PER=$GET(PER)
SET ONE=$GET(ONE)
SET FRACTURE=""
+6 SET (INPTDX,OUTPTDX)=""
SET POVEVER=0
+7 SET REC=$GET(^AUPNPROB(PRIEN,0))
+8 SET REC8=$GET(^AUPNPROB(PRIEN,800))
+9 IF $PIECE(REC,U,2)'=DFN
QUIT
+10 SET POVIEN=$PIECE(REC,U)
+11 IF POVIEN=""
QUIT
+12 ;IHS/MSC/MGH Patch 12 changes
+13 SET EVNDT=$$FMTDATE^BGOUTL($PIECE($GET(^AUPNPROB(PRIEN,0)),U,8))
+14 SET ICD=$PIECE($$ICDDX^ICDEX(POVIEN,EVNDT,"","I"),U,2)
+15 IF ICD=""
QUIT
+16 ;Check for which statuses to return
+17 SET STAT=$PIECE(REC,U,12)
+18 IF STAT="D"
QUIT
+19 ;Q:TYP'[STAT
+20 IF STAT=""
SET STAT="I"
+21 ;P20 Inactive/Phx Handled Below
IF STAT'="I"
IF TYP'[STAT
QUIT
+22 SET STAT2=$$GET1^DIQ(9000011,PRIEN,.12)
+23 SET CONCT=$PIECE(REC8,U,1)
+24 SET DESCT=$PIECE(REC8,U,2)
+25 ;MSC/MGH Patch 23
+26 SET SNODATA=$$CONC^BSTSAPI(CONCT_"^^^1")
+27 SET FRACTURE=$PIECE(SNODATA,U,10)
+28 SET FXLST=$PIECE(SNODATA,U,11)
+29 ;MSC/MGH Patch 20
+30 SET DEFST=""
+31 IF ONE=1
Begin DoDot:1
+32 ;S SNODATA=$$CONC^AUPNSICD(CONCT_"^^^1")
+33 SET DEFST=$PIECE(SNODATA,U,9)
+34 IF STAT="I"&(DEFST="")
SET DEFST="Episodic"
End DoDot:1
+35 SET CLS=$PIECE(REC,U,4)
+36 IF CLS=""
SET CLS="U"
+37 ;Q:'+ONE&(STAT="I")&(((CLS'="P")&(PER="P"))!((CLS="P")&(PER'="P"))) ;P20
+38 SET FLTR=0
Begin DoDot:1
+39 ;Requested specific problem
IF +ONE
QUIT
+40 ;Not inactive or PHx
IF STAT'="I"
QUIT
+41 ;Inactive, but don't want
IF CLS'="P"
IF TYP'["I"
SET FLTR=1
QUIT
+42 ;PHx, but don't want
IF CLS="P"
IF TYP'["P"
SET FLTR=1
QUIT
End DoDot:1
IF FLTR
QUIT
+43 IF CLS="P"
SET ARRAY(ICD)=""
+44 SET PNAR=$$GET1^DIQ(9000011,PRIEN,.05)
+45 IF PNAR=""
QUIT
+46 SET FACIEN=+$PIECE(REC,U,6)
+47 SET FACAB=$PIECE($GET(^AUTTLOC(FACIEN,0)),U,7)
SET FAC=$PIECE($GET(^(0)),U,10)
+48 ;P6
IF $GET(DUZ("AG"))'="I"
IF '$LENGTH(FAC)
SET FAC=999999
+49 IF FAC'?6N
QUIT
+50 SET NMBCOD=$PIECE(REC,U,7)
+51 IF 'NMBCOD
QUIT
+52 IF FACAB=""
SET FACAB="ZZZZ"
+53 IF $LENGTH(FACAB)
SET NMBCOD=FACAB_"-"_NMBCOD
+54 SET PRV=$PIECE($GET(^AUPNPROB(PRIEN,1)),U,4)
+55 IF PRV
SET PRV=$PIECE($GET(^VA(200,+PRV,0)),U)
+56 SET ONSET=$$FMTDATE^BGOUTL($PIECE(REC,U,13))
+57 SET PIP=$PIECE($GET(^AUPNPROB(PRIEN,0)),U,19)
+58 SET PRI=$ORDER(^BGOPROB("B",PRIEN,0))
+59 IF PRI
SET PRI=$PIECE($GET(^BGOPROB(PRI,0)),U,2)
+60 SET XICD=$$ADDICD^BGOPROB1(PRIEN)
+61 NEW X,VAR
+62 ;P14
SET POVEVER=$$USED^BGOPROB1(PRIEN)
+63 SET VAR=$$GETVAR^CIAVMEVT("ENCOUNTER.ID.ALTERNATEVISITID",,"CONTEXT.ENCOUNTER")
+64 SET VIEN=""
+65 IF VAR'=""
Begin DoDot:1
+66 SET VIEN=$$VSTR2VIS^BEHOENCX(DFN,VAR)
+67 IF VIEN<1
QUIT
+68 IF $PIECE($GET(^AUPNVSIT(VIEN,0)),U,7)="H"!($PIECE($GET(^AUPNVSIT(VIEN,0)),U,7)="O")
Begin DoDot:2
+69 SET INPT=""
SET INPT=$ORDER(^AUPNPROB(PRIEN,15,"B",VIEN,INPT))
+70 IF +INPT
SET INPTDX=1
End DoDot:2
+71 IF '$TEST
Begin DoDot:2
+72 SET OUTPT=""
SET OUTPT=$ORDER(^AUPNPROB(PRIEN,14,"B",VIEN,OUTPT))
+73 IF +OUTPT
Begin DoDot:3
+74 NEW VPOV,FOUND
+75 SET FOUND=0
+76 SET VPOV=0
FOR
SET VPOV=$ORDER(^AUPNVPOV("AD",VIEN,VPOV))
IF VPOV=""!(FOUND=1)
QUIT
Begin DoDot:4
+77 IF $PIECE($GET(^AUPNVPOV(VPOV,0)),U,16)=PRIEN
Begin DoDot:5
+78 SET OUTPTDX=VPOV
+79 SET FOUND=1
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+80 SET NORMAL=""
+81 IF DESCT'=""
DO QUALLK^BGOVPOV1(.NORMAL,DESCT,"N")
+82 SET ASM=""
+83 DO CHKASM^BGOASLK(.ASM,ICD,DESCT)
+84 ;IHS/MSC/MGH Patch 20 for laterality
SET LAT=$$LAT^BGOPROB1(PRIEN)
+85 SET CNT=CNT+1
+86 ;S @RET@(CNT)=NMBCOD_U_DFN_U_ICD_U_MODDT_U_CLS_U_PNAR_U_DENT_U_STAT_U_ONSET_U_PRIEN_U_NOTES_U_POVIEN_U_ICDNAME_U_PRV_U_FACIEN_U_PRI_U_CLASS
+87 SET @RET@(CNT)="P"_U_PRIEN_U_CONCT_U_DESCT_U_NMBCOD_U_STAT2_U_ONSET_U_PNAR_U_ICD_U_PRI_U_CLS_U_PIP_U_XICD_U_INPTDX_U_OUTPTDX_U_POVEVER_U_ASM_U_NORMAL_U_LAT_U_DEFST
+88 ;Patch 20 added for sorting
+89 DO P1^BGOPROB2(.RET,.CNT,DFN,PRIEN,DESCT)
+90 ;MSC/MGH Patch 23
+91 IF FRACTURE'=""
Begin DoDot:1
+92 SET CNT=CNT+1
+93 SET @RET@(CNT)="F"_U_FRACTURE_U_FXLST
End DoDot:1
+94 ;Return qualifiers for this problem
+95 NEW QUAL,QNODE,SNO,TXT,X,QPRV
+96 SET TXT=""
+97 NEW YQ,Z
+98 FOR YQ=13,17,18
Begin DoDot:1
+99 SET QUAL=1
FOR
SET QUAL=$ORDER(^AUPNPROB(PRIEN,YQ,QUAL))
IF '+QUAL
QUIT
Begin DoDot:2
+100 SET CNT=CNT+1
+101 SET QNODE=$GET(^AUPNPROB(PRIEN,YQ,QUAL,0))
+102 SET SNO=$PIECE(QNODE,U,1)
+103 SET X=$$CONC^BSTSAPI(SNO_"^^^1")
+104 IF $PIECE(X,U,1)'=""
SET TXT=$PIECE(X,U,4)
+105 SET Z=$SELECT(YQ=13:"S",YQ=17:"F",YQ=18:"C")
+106 SET QPRV=$PIECE(QNODE,U,2)
+107 IF QPRV'=""
SET QPRV=$PIECE($GET(^VA(200,QPRV,0)),U)
+108 ;S @RET@(CNT)="Q"_U_Z_U_QUAL_U_SNO_U_TXT_U_$P(QNODE,U,2)_U_$P(QNODE,U,3)
+109 SET @RET@(CNT)="Q"_U_Z_U_QUAL_U_SNO_U_TXT_U_QPRV_U_$$FMTDATE^BGOUTL($PIECE(QNODE,U,3))
End DoDot:2
End DoDot:1
+110 ;IHS/MSC/MGH Patch 15 moved to new routine
+111 ;Get the asthm control information
+112 SET CONTROL=$$CLASS^BGOPROB2(REC,DFN,ASM)
+113 IF CONTROL'=""
Begin DoDot:1
+114 SET CNT=CNT+1
+115 SET @RET@(CNT)=CONTROL
End DoDot:1
+116 ;Return notes for this problem
+117 SET NOTES=""
+118 DO NOTES^BGOPRBN(.NOTES,PRIEN,1)
+119 SET I=""
FOR
SET I=$ORDER(NOTES(I))
IF I=""
QUIT
Begin DoDot:1
+120 SET CNT=CNT+1
+121 SET @RET@(CNT)="N"_U_$GET(NOTES(I))
End DoDot:1
+122 SET INJSTR=$$INJCHK^BGOPROB2(PRIEN,VIEN)
+123 IF INJSTR'=""
Begin DoDot:1
+124 SET CNT=CNT+1
+125 SET @RET@(CNT)=INJSTR
End DoDot:1
+126 ;Return goals, care plans, visit instructions and treatments, consults, referrals and education topics
+127 IF +ACT>0
Begin DoDot:1
+128 DO GET^BGOCPLAN(.RET,PRIEN,DFN,"G",CPTYP,.CNT)
+129 DO GET^BGOCPLAN(.RET,PRIEN,DFN,"P",CPTYP,.CNT)
+130 DO GET^BGOVVI(.RET,DFN,PRIEN,NUM,.CNT)
+131 DO GET^BGOVTR(.RET,DFN,PRIEN,NUM,.CNT)
+132 IF ACT=2
DO GET^BGOVOB(.RET,DFN,PRIEN,NUM,.CNT)
+133 DO GETCON^BGOVTR(.RET,DFN,PRIEN,NUM,.CNT)
+134 DO GETREF^BGOVTR(.RET,DFN,PRIEN,NUM,.CNT)
+135 DO GETEDU^BGOVTR(.RET,DFN,PRIEN,NUM,.CNT)
End DoDot:1
+136 QUIT
+137 ; Delete a problem entry
+138 ; PRIEN = Problem IEN ^ TYPE ^ DELETE REASON ^ OTHER^PROB ID
DEL(RET,PRIEN) ;EP
+1 DO DEL^BGOPROB3(.RET,PRIEN)
+2 QUIT
+3 ; Add 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 ; ^ INP 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] ^ Delete [7]
+13 ; SPEC = Special conditions
+14 ; PIP = Prenatal Problem sent from PIP
SET(RET,DFN,PRIEN,VIEN,ARRAY,SPEC,PIP) ;EP
+1 NEW CLASS,DIEN,ONSET,NARR,LIEN,PRNUM,LOCN,DMOD,DENT,VAPR,INP,INPT,SNODATA
+2 NEW FDA,IEN,FPNUM,FPIEN,FNUM,IENS,PRNEW,PRIOR,SNOCT,DESCT,XIEN,ERR,IMP,INDIEN
+3 SET SPEC=$GET(SPEC)
SET PIP=$GET(PIP)
+4 SET FNUM=$$FNUM
SET RET=""
SET ERR=0
+5 SET (DIEN,SNOCT)=""
+6 SET PRIEN=$GET(PRIEN)
SET VIEN=$GET(VIEN)
+7 SET XIEN=""
FOR
SET XIEN=$ORDER(ARRAY(XIEN))
IF XIEN=""!(ERR=1)
QUIT
Begin DoDot:1
+8 SET INP=$GET(ARRAY(XIEN))
+9 IF $PIECE(ARRAY(XIEN),U,1)="P"
DO PROB(.RET,INP,SPEC,PIP)
+10 IF $PIECE(ARRAY(XIEN),U,1)="A"
DO ASTHMA(.RET,VIEN,INP,DIEN,DESCT)
+11 IF $PIECE(ARRAY(XIEN),U,1)="Q"
DO QUAL(.RET,INP)
End DoDot:1
+12 QUIT
PROB(RET,INP,SPEC,PIP) ;PROBLEM DATA
+1 NEW X,INDIEN,LAT,LATEXT
+2 SET INDIEN=$PIECE($PIECE(INP,U,5),"|",1)
+3 SET NARR=$PIECE(INP,U,4)
+4 SET NARR=$TRANSLATE(NARR,"^|","")
+5 SET LIEN=$PIECE(INP,U,6)
+6 SET ONSET=$$CVTDATE^BGOUTL($PIECE(INP,U,7))
+7 SET CLASS=$PIECE(INP,U,9)
+8 SET SNOCT=$PIECE(INP,U,2)
+9 ; IHS/MSC/MGH changed to new API-P14
+10 ;S SNODATA=$$CONC^BSTSAPI(SNOCT_"^^^1")
+11 SET SNODATA=$$CONC^AUPNSICD(SNOCT_"^^^1")
+12 ;IHS/MSC/MGH changed to handle special cases p14
+13 IF +SPEC
SET DIEN=INDIEN
+14 IF '$TEST
SET DIEN=$PIECE($PIECE(SNODATA,U,5),";",1)
+15 ;I ((DIEN="")!(DIEN=".9999")!(DIEN="ZZZ.999"))&(INDIEN'="") S DIEN=INDIEN
+16 IF DIEN=""
Begin DoDot:1
+17 ;Patch 14 check for which undefined code to use
+18 SET IMP=$$IMP^ICDEX("10D",DT)
+19 IF IMP'>$$NOW^XLFDT
SET DIEN="ZZZ.999"
+20 IF IMP>$$NOW^XLFDT
SET DIEN=".9999"
End DoDot:1
+21 IF DIEN'["."
SET DIEN=DIEN_"."
+22 SET DESCT=$PIECE(INP,U,3)
+23 ;I CLASS="P"&(DUZ("AG")'="I") S CLASS="I"
+24 SET STAT=$PIECE(INP,U,8)
+25 ;MSC/MGH Store default status from lookup patch 20
+26 IF STAT=""
SET STAT=$PIECE(SNODATA,U,9)
+27 IF STAT=""
SET STAT="Episodic"
+28 SET STAT=$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")
+29 SET VAPR=$SELECT(STAT="A":"C",STAT="S":"C",STAT="O":"C",STAT="E":"A",STAT="R":"C",1:"")
+30 IF '$DATA(^DPT(DFN,0))
SET ERR=1
SET RET=$$ERR^BGOUTL(1001)
QUIT
+31 SET PRNUM=$PIECE(INP,U,10)
+32 SET PRNEW='PRIEN
+33 SET PRIOR=$PIECE(INP,U,11)
+34 SET DIEN=$PIECE($$ICDDX^ICDEX(DIEN,"","","E"),U,1)
+35 IF 'DIEN
SET ERR=1
SET RET=$$ERR^BGOUTL(1048)
QUIT
+36 ;IHS/MSC/MGH update date modified to include time
+37 SET DMOD=$$NOW^XLFDT
SET DENT=$SELECT(PRIEN:"",1:DT)
+38 IF 'LIEN
SET ERR=1
SET RET=$$ERR^BGOUTL(1049)
QUIT
+39 ;Provider narrative is now provider text | descriptive SNOMED CT
+40 ;Patch 20 provider narrative is now provider text | descriptive SNOMED CT | laterality
+41 SET LAT=$PIECE(INP,U,13)
+42 ;Do not store unspecified laterality
+43 IF LAT="272741003|261665006"!(LAT="272741003|")
SET LAT=""
+44 IF LAT'=""
Begin DoDot:1
+45 SET LATEXT=$$CVPARM^BSTSMAP1("LAT",$PIECE(LAT,"|",2))
+46 SET NARR=NARR_"|"_DESCT_"|"_LATEXT
End DoDot:1
+47 IF '$TEST
SET NARR=NARR_"|"_DESCT
+48 IF $LENGTH(NARR)
Begin DoDot:1
+49 SET RET=$$FNDNARR^BGOUTL2(NARR)
+50 IF RET>0
SET NARR=RET
SET RET=""
End DoDot:1
IF RET
QUIT
+51 SET FPIEN=""
+52 IF PRIEN
Begin DoDot:1
+53 SET IENS=PRIEN_","
End DoDot:1
+54 IF '$TEST
Begin DoDot:1
+55 IF 'PRNUM
SET PRNUM=1+$EXTRACT($ORDER(^AUPNPROB("AA",DFN,LIEN,""),-1),2,99)
+56 SET (FPIEN,FPNUM)=""
+57 SET IENS="+1,"
End DoDot:1
+58 SET FDA=$NAME(FDA(FNUM,IENS))
+59 SET @FDA@(.01)=DIEN
+60 IF PRNEW
SET @FDA@(.02)=DFN
+61 SET @FDA@(.03)=DMOD
+62 SET @FDA@(.14)=DUZ
+63 IF CLASS="P"
SET STAT="I"
+64 SET @FDA@(.04)=$SELECT($LENGTH(CLASS):CLASS,1:"@")
+65 SET @FDA@(.05)=$SELECT(NARR:NARR,1:"@")
+66 IF PRNEW
SET @FDA@(.06)=LIEN
+67 IF PRNUM
SET @FDA@(.07)=PRNUM
+68 IF PRNEW
SET @FDA@(.08)=DENT
+69 SET @FDA@(1.03)=DUZ
+70 SET @FDA@(.12)=STAT
+71 SET @FDA@(.13)=ONSET
+72 IF PRNEW
SET @FDA@(1.04)=DUZ
+73 SET @FDA@(1.14)=VAPR
+74 SET @FDA@(80001)=SNOCT
+75 SET @FDA@(80002)=DESCT
+76 ;Patch 20
IF $PIECE(LAT,"|",2)'=""
SET @FDA@(.22)=LAT
+77 SET RET=$$UPDATE^BGOUTL(.FDA,,.IEN)
+78 IF RET
QUIT
+79 IF 'PRIEN
SET PRIEN=IEN(1)
+80 DO SETPRI(,PRIEN_U_PRIOR)
+81 ;IHS/MSC/MGH Set prenatal PIP if called from CVG Patch 20
+82 IF +PIP
Begin DoDot:1
+83 ;Set Prenatal PIP entry
IF $$TEST^CIAUOS("SET^BJPNAPIS")
SET RET=$$SET^BJPNAPIS(PRIEN)
IF RET
QUIT
End DoDot:1
+84 IF 'RET
SET RET=PRIEN
+85 IF RET>0
DO EVT(PRIEN,'PRNEW)
+86 NEW RES
+87 ;Set any extra ICD codes
+88 DO SETICD^BGOPROB1(.RES,PRIEN,$PIECE(SNODATA,U,5),";")
+89 ;Set inpt DX
+90 NEW RES1
+91 SET INPT=$PIECE(INP,U,12)
+92 IF INPT=1
SET RES1=""
DO HOSP^BGOHOS(.RES1,PRIEN,VIEN)
+93 ;S:FPIEN RET=$$DELETE^BGOUTL(FPNUM,FPIEN)
+94 ;S:'RET&(DUZ("AG")="I") RET=$$SETFP(PRIEN)
+95 QUIT
ASTHMA(RET,VIEN,INP,DIEN,DESCT) ;ASTHMA DATA
+1 DO ASTHMA^BGOPROB3(.RET,VIEN,INP,DIEN,DESCT)
+2 QUIT
QUAL(RET,INP) ;QUALIFIERS
+1 DO QUAL^BGOPROB1(.RET,INP)
+2 QUIT
+3 ; 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 ; Return file number
FNUM() QUIT 9000011
