BGOPROB.m

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)