BJPNSPRB ;GDIT/HS/BEE-Prenatal Care Module Add/Edit RPCs - Other ; 08 May 2012 12:00 PM
;;2.0;PRENATAL CARE MODULE;**6,7,9**;Feb 24, 2015;Build 12
;
Q
;
PCHECK(DATA,DFN,CONCID,VIEN,DESCID,LAT,PRBIEN,CHG) ;EP - BJPN CHECK FOR PROBLEM
;
;BJPN*2.0*7;Call now being made to PCHECK^BJPNSPRB
D PCHECK^BJPNPCHK(.DATA,DFN,CONCID,VIEN,DESCID,LAT,PRBIEN,CHG)
Q
;
PROB(DATA,PRBIEN,PIPIEN,VIEN) ;EP - BJPN GET PROBLEM
;
;This RPC returns the detail for a particular problem
; * The IPL pointer is required - all relevant IPL data will be returned
; * The PIP pointer is optional - if present the relevant PIP data will be returned
;
;Input:
; PRBIEN - Pointer to IPL
; PIPIEN - Pointer to PIP (optional)
; VIEN - Visit IEN
;
NEW UID,II,RET,BGO,TMP,B,P,T,VDT,DFN,ONSET,LOC,EPROB,IPROB,IPRIO,CLASS,EP,INJREV,INJPLC,INJDT,EPSMD,EVAR
NEW DEL,DESCID,CONCID,DESCTM,PTEXT,PNARR,BGO,API,XPRI,XSTS,XLMDT,XLMBY,IPLSTS,PRIMARY,QUAL,ASTHMA
NEW ICD,ADDICD,ICDCNT,ADICD,HICD,GGO,CGO,VGO,GOAL,CARE,INST,DEDD,POV,IPOV,ITYPE,PRV,XPRV,XSCO,PVIEN
NEW INJASS,INJCIEN,INJCCOD,INJCDSC,INJCHK,ABN,PLAT,ILAT,ELAT,FRACT
;
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BJPNSPRB",UID))
K @DATA
I $G(DT)=""!($G(U)="") D DT^DICRW
;
;Set up Header
S II=0
S @DATA@(II)="I00010PIPIEN^I00010PRBIEN^T00012PRIORITY^T00001PIP_STATUS^T00025SCOPE"
S @DATA@(II)=@DATA@(II)_"^T00025DESC_ID^T00500DESC_TERM^T00025CONC_ID^T00001IPL_PRIORITY^T00001CLASS"
S @DATA@(II)=@DATA@(II)_"^D00030LM_DT^T00050LM_BY^T00010IPL_STS^T00120ICD^T04096HOVER_ICD"
S @DATA@(II)=@DATA@(II)_"^T00160PROVIDER_TEXT^T00360PROVIDER_NARRATIVE^T04096LAST_GOAL"
S @DATA@(II)=@DATA@(II)_"^T04096LAST_CARE_PLAN^T04096LAST_VISIT_INSTRUCTION"
S @DATA@(II)=@DATA@(II)_"^I00010HIDE_PRV^T00035PRV^D00015DEFINITIVE_EDD^T00001POV"
S @DATA@(II)=@DATA@(II)_"^T00001INPATIENT_POV^T00001PRIMARY^T00001PATIENT_TYPE^T00030ONSET_DT"
S @DATA@(II)=@DATA@(II)_"^T00050LOCATION^T00015EXTERNAL_PROB^T00015INTERNAL_PROB"
S @DATA@(II)=@DATA@(II)_"^T00015POV_IEN^T00250ASTHMA^T00050EPISODICITY^T00025EPISODICITY_SMD^T00050INJURY_REVISIT"
S @DATA@(II)=@DATA@(II)_"^T00050INJURY_PLACE^D00030INJURY_DT^T00050INJ_ASSOC^I00020INJ_CAUSE_IEN"
S @DATA@(II)=@DATA@(II)_"^T00020INJ_CAUSE_CODE^T00200INJ_CAUSE_DESC^T00001INJ_CHECKED^T04096QUALIFIERS^T00001ABNORMAL"
S @DATA@(II)=@DATA@(II)_"^T00001PROMPT_LATERALITY^T00040INT_LATERALITY^T00040EXT_LATERALITY^T00040FRACTURE"_$C(30)
;
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BJPNSPRB D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
;
;Verify PRBIEN and VIEN (at minimum) were entered
I $G(PRBIEN)="" S BMXSEC="Required IPL PRBIEN is missing" G XPROB
I $G(VIEN)="" S BMXSEC="Required visit IEN is missing" G XPROB
S PIPIEN=$G(PIPIEN) S:PIPIEN=0 PIPIEN=""
;
;Get the DFN
S DFN=$$GET1^DIQ(9000011,PRBIEN_",",.02,"I") I DFN="" S BMXSEC="Invalid DFN value in IPL entry" G XPROB
;
;If PIPIEN, verify it matches to PRBIEN
I $G(PIPIEN)]"",'$D(^BJPNPL("F",DFN,PRBIEN,PIPIEN)) S BMXSEC="The PIPIEN does not point to the IPL entry" G XPROB
;
;Get the visit date or default to DT if visit not passed in
I $G(VIEN)]"" S VDT=$P($$GET1^DIQ(9000010,VIEN_",",".01","I"),".")
S:$G(VDT)="" VDT=DT
;
;Call EHR API and format results into usable data
D COMP^BJPNUTIL(DFN,UID,VIEN,PRBIEN)
S TMP=$NA(^TMP("BJPNIPL",UID)) ;Define compiled data reference
;
;Get IPL and PIP information
;
;Skip deletes
S DEL=$$GET1^DIQ(9000011,PRBIEN_",",2.02,"I") I DEL]"" D S BMXSEC="The input IPL problem has been deleted" G XPROB ;IPL Delete
. ;
. ;If deleted on IPL, need to make sure it is deleted in PIP
. NEW BJPNUPD,ERROR
. S BJPNUPD(90680.01,PIPIEN_",",2.01)=$$GET1^DIQ(9000011,PRBIEN_",",2.01,"I") ;Deleted By
. S BJPNUPD(90680.01,PIPIEN_",",2.02)=$$GET1^DIQ(9000011,PRBIEN_",",2.02,"I") ;Del Dt/Tm
. S BJPNUPD(90680.01,PIPIEN_",",2.03)=$$GET1^DIQ(9000011,PRBIEN_",",2.03,"I") ;Del Rsn
. S BJPNUPD(90680.01,PIPIEN_",",2.04)=$$GET1^DIQ(9000011,PRBIEN_",",2.04,"I") ;Del Other
. D FILE^DIE("","BJPNUPD","ERROR")
S DEL=$$GET1^DIQ(90680.01,PIPIEN_",",2.01,"I") I DEL]"" S PIPIEN="",BMXSEC="The input PIP problem has been deleted" G XPROB
;
;Retrieve the entry from the API results
S BGO=$O(@TMP@("P",PRBIEN,"")) I BGO="" G XPROB ;Quit if no IPL entry
S API=$G(@TMP@("P",PRBIEN,BGO)) I API="" G XPROB ;Quit if no problem string
;
;SNOMED DescId and ConcId
S DESCID=$P(API,U,4)
S:DESCID="" DESCID=$$GET1^DIQ(9000011,PRBIEN_",",80002,"I") I DESCID="" G XPROB ;Quit if no Desc ID
S DESCTM=$P($$DESC^BSTSAPI(DESCID_"^^1"),U,2) I DESCTM="" G XPROB ;Quit if no Description Term
S CONCID=$P(API,U,3)
S:CONCID="" CONCID=$$GET1^DIQ(9000011,PRBIEN_",",80001,"I") I CONCID="" G XPROB ;Quit if no Concept ID
;
;Onset Date
S ONSET=$$GET1^DIQ(9000011,PRBIEN_",",.13,"I")
I ONSET]"" D
. I $E(ONSET,4,7)="0000" S ONSET="20"_$E(ONSET,2,3) Q ;Year only
. I $E(ONSET,6,7)="00" S ONSET=+$E(ONSET,4,5)_"/20"_$E(ONSET,2,3) Q ;Month/Year
. S ONSET=$$FMTE^BJPNPRL(ONSET)
;
;Location
S LOC=$$GET1^DIQ(9000011,PRBIEN_",",.06,"I")
;
;External problem
S EPROB=$P(API,U,5)
;
;Internal problem
S IPROB=$$GET1^DIQ(9000011,PRBIEN_",",.07,"I")
;
;PIP Priority
I +PIPIEN S XPRI=$$GET1^DIQ(90680.01,PIPIEN_",",.06,"E")
E S XPRI=""
;
;IPL Priority
S IPRIO="" I PRBIEN]"" D
. NEW PRIEN
. S PRIEN=$O(^BGOPROB("B",PRBIEN,"")) Q:PRIEN=""
. S IPRIO=$$GET1^DIQ(90362.22,PRIEN_",",.02,"I")
. S:IPRIO="" IPRIO=0
;
;Status
I +PIPIEN S XSTS=$$GET1^DIQ(90680.01,PIPIEN_",",.08,"E")
E S XSTS=""
;
;Scope
I +PIPIEN S XSCO=$$GET1^DIQ(90680.01,PIPIEN_",",.07,"E")
E S XSCO=""
;
;Class
S CLASS=$$GET1^DIQ(9000011,PRBIEN_",",.04,"I")
;
;Last Modified Date
S XLMDT=$$FMTE^BJPNPRL($$GET1^DIQ(9000011,PRBIEN_",",.03,"I"))
;
;Last Modified By
S XLMBY=$$GET1^DIQ(9000011,PRBIEN_",",.14,"E")
;
;IPL Status - Convert manually lower case can be displayed
S IPLSTS=$P(API,U,6)
S:IPLSTS="" IPLSTS=$$GET1^DIQ(9000011,PRBIEN_",",.12,"E")
S IPLSTS=$S(IPLSTS="CHRONIC":"Chronic",IPLSTS="INACTIVE":"Inactive",IPLSTS="D":"DELETED",IPLSTS="SUB-ACUTE":"Sub-Acute",IPLSTS="EPISODIC":"Episodic",IPLSTS="SOCIAL":"Social",IPLSTS="ROUTINE/ADMIN":"Admin",1:"")
;
;ICD Information - Pull primary and additional ICD values
S ICD=$P(API,U,9)
S ADDICD=$P(API,U,13)
I ADDICD]"" F ICDCNT=1:1:$L(ADDICD,"|") S ADICD=$P(ADDICD,"|",ICDCNT) I ADICD]"" S ICD=ICD_$S(ICD]"":"|",1:"")_ADICD
;
;ICD Hover field - Not used for problem add/edit
S HICD=""
;
;Provider Text
S PNARR=$P(API,U,8)
S PTEXT=$P(PNARR," | ",2)
;
;Get latest Goal note
S GGO=$O(@TMP@("G",PRBIEN,""))
S GOAL="" I GGO]"" S GOAL=$P($G(@TMP@("G",PRBIEN,GGO,1)),U,2)
;
;Get latest Care Plan note
S CGO=$O(@TMP@("C",PRBIEN,""))
S CARE="" I CGO]"" S CARE=$P($G(@TMP@("C",PRBIEN,CGO,1)),U,2)
;
;Get latest V Visit Instruction
S VGO=$O(@TMP@("I",PRBIEN,""))
S INST="" I VGO]"" S INST=$P($G(@TMP@("I",PRBIEN,VGO,1)),U,2)
;
;Visit POV
S (IPOV,POV,ITYPE)="" I VIEN]"" D
. S ITYPE=$$GET1^DIQ(9000010,VIEN_",",.07,"I") Q:ITYPE=""
. S ITYPE=$S(ITYPE="H":"H",1:"A")
. I $O(^AUPNPROB(PRBIEN,14,"B",VIEN,"")) S POV="Y"
. I $O(^AUPNPROB(PRBIEN,15,"B",VIEN,"")) S IPOV="Y"
;
;Get Primary/Secondary value
S PRIMARY=$P(API,U,30)
;
;Get V POV IEN
S PVIEN=$P(API,U,31)
;
;Get the Episodicity
S EP=$P(API,U,32)
S EPSMD=$$VALTERM^BSTSAPI("EVAR",EP_"^^1")
S EPSMD=$G(EVAR(1,"CON"))
;
;Get the injury revisit
S INJREV=$P(API,U,33)
;
;Get the injury place
S INJPLC=$P(API,U,34)
;
;Get the injury date
S INJDT=$P(API,U,35)
;
S INJASS=$P(API,U,38)
S INJCIEN="" I PVIEN]"" S INJCIEN=$$GET1^DIQ(9000010.07,PVIEN_",",.09,"I")
S INJCCOD=$P(API,U,37)
S INJCDSC=$P(API,U,36)
S INJCHK="" I (INJPLC]"")!(INJCCOD]"")!(INJCDSC]"")!(INJASS]"")!(INJCIEN]"")!(INJDT]"") S INJCHK="Y"
;
;Definitive EDD
I +PIPIEN S DEDD=$$FMTE^BJPNPRL($$GET1^DIQ(90680.01,PIPIEN_",",.09,"I"))
E S DEDD=""
;
;PRV fields
S (PRV,XPRV)=""
S PRV=$$PPRV^BJPNPKL(VIEN)
S:PRV]"" XPRV=$$GET1^DIQ(200,PRV_",",.01,"E")
;
;Qualifiers - Loop through entries and assemble
S QUAL="",BGO="" F S BGO=$O(@TMP@("Q",PRBIEN,BGO)) Q:BGO="" D
. ;
. NEW STR,N
. S N=$G(@TMP@("Q",PRBIEN,BGO,0))
. ;Return: TYPE (C/S) [1] 29 IEN [2] 29 CONCID [3] 29 TERM [4] 29 LMDT [5] 29 LMBY [6]
. S STR=$P(N,U,2)_$C(29)_$P(N,U,3)_$C(29)_$P(N,U,4)_$C(29)_$P(N,U,5)_$C(29)_$C(29)
. ;
. ;If IEN is populated and severity - get last modified by
. I +$P(N,U,3),$P(N,U,2)="S" D
.. NEW DA,IENS,BY,LMDT,LMBY
.. S DA(1)=PRBIEN,DA=$P(N,U,3),IENS=$$IENS^DILF(.DA)
.. S LMDT=$$GET1^DIQ(9000011.13,IENS,.05,"I")
.. S LMBY=$$GET1^DIQ(9000011.13,IENS,.04,"I")
.. I LMDT="" D
... S LMDT=$$GET1^DIQ(9000011.13,IENS,.03,"I")
... S LMBY=$$GET1^DIQ(9000011.13,IENS,.02,"I")
.. S $P(STR,$C(29),5)=LMBY
.. S $P(STR,$C(29),6)=LMDT
. ;
. S QUAL=QUAL_$S(QUAL="":"",1:$C(28))_STR
;
;Asthma
S ASTHMA="",BGO=$O(@TMP@("A",PRBIEN,"")) I BGO]"" D
. S ASTHMA=$TR($G(@TMP@("A",PRBIEN,BGO,0)),"^",$C(29))
;
;Abnormal Findings
S ABN=$P(API,U,39)
;
;BJPN*2.0*7;Added laterality
S PLAT=$P(API,U,19),PLAT=$S(PLAT=1:"Y",1:"N") ;Prompt for laterality
S ILAT=$P(API,U,20)
S ELAT="" I $TR(ILAT,"|")]"" S ELAT=$$CVPARM^BSTSMAP1("LAT",$P(ILAT,"|"))_"|"_$$CVPARM^BSTSMAP1("LAT",$P(ILAT,"|",2))
;
;BJPN*2.0*9;Added Fracture Healing
S FRACT=$P(API,U,40)
;
;Set up entry
S II=II+1,@DATA@(II)=PIPIEN_U_PRBIEN_U_XPRI_U_XSTS_U_XSCO_U_DESCID_U_DESCTM_U_CONCID_U_IPRIO_U_CLASS_U_XLMDT_U_XLMBY_U_IPLSTS
S @DATA@(II)=@DATA@(II)_U_ICD_U_HICD_U_PTEXT_U_PNARR_U_GOAL_U_CARE_U_INST_U_PRV_U_XPRV
S @DATA@(II)=@DATA@(II)_U_DEDD_U_POV_U_IPOV_U_PRIMARY_U_ITYPE_U_ONSET_U_LOC_U_EPROB
S @DATA@(II)=@DATA@(II)_U_IPROB_U_PVIEN_U_ASTHMA_U_EP_U_EPSMD_U_INJREV_U_INJPLC_U_INJDT
S @DATA@(II)=@DATA@(II)_U_INJASS_U_INJCIEN_U_INJCCOD_U_INJCDSC_U_INJCHK_U_QUAL_U_ABN_U_PLAT_U_ILAT_U_ELAT_U_FRACT
S @DATA@(II)=@DATA@(II)_$C(30)
;
XPROB S II=II+1,@DATA@(II)=$C(31)
Q
;
SUBSET(DATA,SUBSET) ;EP - BJPN GET SUBSET
;
;This RPC accepts a SNOMED subset value and returns the entries in the subset
;
;Input parameter:
; SUBSET - The SNOMED subset to look up and return a list of members
;
NEW CNT,UID,II,RET,OUT
;
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BJPNSPRB",UID))
K @DATA
I $G(DT)=""!($G(U)="") D DT^DICRW
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BJPNSPRB D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
;
;Define Header
S @DATA@(0)="T00300TEXT^T00025DESC_ID^T00025CONC_ID"_$C(30)
;
;Input checks
I $G(SUBSET)="" S BMXSEC="Missing Subset" G XSUBSET
;
;Call EHR API to retrieve the list of information
S OUT="RET"
;
;Default to local search
S $P(SUBSET,U,3)=1
;
D SUBLST^BSTSAPI(OUT,SUBSET)
;
;Loop through results and output
S CNT="" F S CNT=$O(RET(CNT)) Q:CNT="" D
. NEW N
. S N=$G(RET(CNT))
. S II=II+1,@DATA@(II)=$P(N,U,3)_U_$P(N,U,2)_U_$P(N,U)_$C(30)
;
XSUBSET S II=II+1,@DATA@(II)=$C(31)
Q
;
ERR ;
D ^%ZTER
NEW Y,ERRDTM
S Y=$$NOW^XLFDT() X ^DD("DD") S ERRDTM=Y
S II=II+1,@DATA@(II)=$C(31)
Q
BJPNSPRB ;GDIT/HS/BEE-Prenatal Care Module Add/Edit RPCs - Other ; 08 May 2012 12:00 PM
+1 ;;2.0;PRENATAL CARE MODULE;**6,7,9**;Feb 24, 2015;Build 12
+2 ;
+3 QUIT
+4 ;
PCHECK(DATA,DFN,CONCID,VIEN,DESCID,LAT,PRBIEN,CHG) ;EP - BJPN CHECK FOR PROBLEM
+1 ;
+2 ;BJPN*2.0*7;Call now being made to PCHECK^BJPNSPRB
+3 DO PCHECK^BJPNPCHK(.DATA,DFN,CONCID,VIEN,DESCID,LAT,PRBIEN,CHG)
+4 QUIT
+5 ;
PROB(DATA,PRBIEN,PIPIEN,VIEN) ;EP - BJPN GET PROBLEM
+1 ;
+2 ;This RPC returns the detail for a particular problem
+3 ; * The IPL pointer is required - all relevant IPL data will be returned
+4 ; * The PIP pointer is optional - if present the relevant PIP data will be returned
+5 ;
+6 ;Input:
+7 ; PRBIEN - Pointer to IPL
+8 ; PIPIEN - Pointer to PIP (optional)
+9 ; VIEN - Visit IEN
+10 ;
+11 NEW UID,II,RET,BGO,TMP,B,P,T,VDT,DFN,ONSET,LOC,EPROB,IPROB,IPRIO,CLASS,EP,INJREV,INJPLC,INJDT,EPSMD,EVAR
+12 NEW DEL,DESCID,CONCID,DESCTM,PTEXT,PNARR,BGO,API,XPRI,XSTS,XLMDT,XLMBY,IPLSTS,PRIMARY,QUAL,ASTHMA
+13 NEW ICD,ADDICD,ICDCNT,ADICD,HICD,GGO,CGO,VGO,GOAL,CARE,INST,DEDD,POV,IPOV,ITYPE,PRV,XPRV,XSCO,PVIEN
+14 NEW INJASS,INJCIEN,INJCCOD,INJCDSC,INJCHK,ABN,PLAT,ILAT,ELAT,FRACT
+15 ;
+16 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+17 SET DATA=$NAME(^TMP("BJPNSPRB",UID))
+18 KILL @DATA
+19 IF $GET(DT)=""!($GET(U)="")
DO DT^DICRW
+20 ;
+21 ;Set up Header
+22 SET II=0
+23 SET @DATA@(II)="I00010PIPIEN^I00010PRBIEN^T00012PRIORITY^T00001PIP_STATUS^T00025SCOPE"
+24 SET @DATA@(II)=@DATA@(II)_"^T00025DESC_ID^T00500DESC_TERM^T00025CONC_ID^T00001IPL_PRIORITY^T00001CLASS"
+25 SET @DATA@(II)=@DATA@(II)_"^D00030LM_DT^T00050LM_BY^T00010IPL_STS^T00120ICD^T04096HOVER_ICD"
+26 SET @DATA@(II)=@DATA@(II)_"^T00160PROVIDER_TEXT^T00360PROVIDER_NARRATIVE^T04096LAST_GOAL"
+27 SET @DATA@(II)=@DATA@(II)_"^T04096LAST_CARE_PLAN^T04096LAST_VISIT_INSTRUCTION"
+28 SET @DATA@(II)=@DATA@(II)_"^I00010HIDE_PRV^T00035PRV^D00015DEFINITIVE_EDD^T00001POV"
+29 SET @DATA@(II)=@DATA@(II)_"^T00001INPATIENT_POV^T00001PRIMARY^T00001PATIENT_TYPE^T00030ONSET_DT"
+30 SET @DATA@(II)=@DATA@(II)_"^T00050LOCATION^T00015EXTERNAL_PROB^T00015INTERNAL_PROB"
+31 SET @DATA@(II)=@DATA@(II)_"^T00015POV_IEN^T00250ASTHMA^T00050EPISODICITY^T00025EPISODICITY_SMD^T00050INJURY_REVISIT"
+32 SET @DATA@(II)=@DATA@(II)_"^T00050INJURY_PLACE^D00030INJURY_DT^T00050INJ_ASSOC^I00020INJ_CAUSE_IEN"
+33 SET @DATA@(II)=@DATA@(II)_"^T00020INJ_CAUSE_CODE^T00200INJ_CAUSE_DESC^T00001INJ_CHECKED^T04096QUALIFIERS^T00001ABNORMAL"
+34 SET @DATA@(II)=@DATA@(II)_"^T00001PROMPT_LATERALITY^T00040INT_LATERALITY^T00040EXT_LATERALITY^T00040FRACTURE"_$CHAR(30)
+35 ;
+36 ; SAC 2009 2.2.3.17
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BJPNSPRB D UNWIND^%ZTER"
+37 ;
+38 ;Verify PRBIEN and VIEN (at minimum) were entered
+39 IF $GET(PRBIEN)=""
SET BMXSEC="Required IPL PRBIEN is missing"
GOTO XPROB
+40 IF $GET(VIEN)=""
SET BMXSEC="Required visit IEN is missing"
GOTO XPROB
+41 SET PIPIEN=$GET(PIPIEN)
IF PIPIEN=0
SET PIPIEN=""
+42 ;
+43 ;Get the DFN
+44 SET DFN=$$GET1^DIQ(9000011,PRBIEN_",",.02,"I")
IF DFN=""
SET BMXSEC="Invalid DFN value in IPL entry"
GOTO XPROB
+45 ;
+46 ;If PIPIEN, verify it matches to PRBIEN
+47 IF $GET(PIPIEN)]""
IF '$DATA(^BJPNPL("F",DFN,PRBIEN,PIPIEN))
SET BMXSEC="The PIPIEN does not point to the IPL entry"
GOTO XPROB
+48 ;
+49 ;Get the visit date or default to DT if visit not passed in
+50 IF $GET(VIEN)]""
SET VDT=$PIECE($$GET1^DIQ(9000010,VIEN_",",".01","I"),".")
+51 IF $GET(VDT)=""
SET VDT=DT
+52 ;
+53 ;Call EHR API and format results into usable data
+54 DO COMP^BJPNUTIL(DFN,UID,VIEN,PRBIEN)
+55 ;Define compiled data reference
SET TMP=$NAME(^TMP("BJPNIPL",UID))
+56 ;
+57 ;Get IPL and PIP information
+58 ;
+59 ;Skip deletes
+60 ;IPL Delete
SET DEL=$$GET1^DIQ(9000011,PRBIEN_",",2.02,"I")
IF DEL]""
Begin DoDot:1
+61 ;
+62 ;If deleted on IPL, need to make sure it is deleted in PIP
+63 NEW BJPNUPD,ERROR
+64 ;Deleted By
SET BJPNUPD(90680.01,PIPIEN_",",2.01)=$$GET1^DIQ(9000011,PRBIEN_",",2.01,"I")
+65 ;Del Dt/Tm
SET BJPNUPD(90680.01,PIPIEN_",",2.02)=$$GET1^DIQ(9000011,PRBIEN_",",2.02,"I")
+66 ;Del Rsn
SET BJPNUPD(90680.01,PIPIEN_",",2.03)=$$GET1^DIQ(9000011,PRBIEN_",",2.03,"I")
+67 ;Del Other
SET BJPNUPD(90680.01,PIPIEN_",",2.04)=$$GET1^DIQ(9000011,PRBIEN_",",2.04,"I")
+68 DO FILE^DIE("","BJPNUPD","ERROR")
End DoDot:1
SET BMXSEC="The input IPL problem has been deleted"
GOTO XPROB
+69 SET DEL=$$GET1^DIQ(90680.01,PIPIEN_",",2.01,"I")
IF DEL]""
SET PIPIEN=""
SET BMXSEC="The input PIP problem has been deleted"
GOTO XPROB
+70 ;
+71 ;Retrieve the entry from the API results
+72 ;Quit if no IPL entry
SET BGO=$ORDER(@TMP@("P",PRBIEN,""))
IF BGO=""
GOTO XPROB
+73 ;Quit if no problem string
SET API=$GET(@TMP@("P",PRBIEN,BGO))
IF API=""
GOTO XPROB
+74 ;
+75 ;SNOMED DescId and ConcId
+76 SET DESCID=$PIECE(API,U,4)
+77 ;Quit if no Desc ID
IF DESCID=""
SET DESCID=$$GET1^DIQ(9000011,PRBIEN_",",80002,"I")
IF DESCID=""
GOTO XPROB
+78 ;Quit if no Description Term
SET DESCTM=$PIECE($$DESC^BSTSAPI(DESCID_"^^1"),U,2)
IF DESCTM=""
GOTO XPROB
+79 SET CONCID=$PIECE(API,U,3)
+80 ;Quit if no Concept ID
IF CONCID=""
SET CONCID=$$GET1^DIQ(9000011,PRBIEN_",",80001,"I")
IF CONCID=""
GOTO XPROB
+81 ;
+82 ;Onset Date
+83 SET ONSET=$$GET1^DIQ(9000011,PRBIEN_",",.13,"I")
+84 IF ONSET]""
Begin DoDot:1
+85 ;Year only
IF $EXTRACT(ONSET,4,7)="0000"
SET ONSET="20"_$EXTRACT(ONSET,2,3)
QUIT
+86 ;Month/Year
IF $EXTRACT(ONSET,6,7)="00"
SET ONSET=+$EXTRACT(ONSET,4,5)_"/20"_$EXTRACT(ONSET,2,3)
QUIT
+87 SET ONSET=$$FMTE^BJPNPRL(ONSET)
End DoDot:1
+88 ;
+89 ;Location
+90 SET LOC=$$GET1^DIQ(9000011,PRBIEN_",",.06,"I")
+91 ;
+92 ;External problem
+93 SET EPROB=$PIECE(API,U,5)
+94 ;
+95 ;Internal problem
+96 SET IPROB=$$GET1^DIQ(9000011,PRBIEN_",",.07,"I")
+97 ;
+98 ;PIP Priority
+99 IF +PIPIEN
SET XPRI=$$GET1^DIQ(90680.01,PIPIEN_",",.06,"E")
+100 IF '$TEST
SET XPRI=""
+101 ;
+102 ;IPL Priority
+103 SET IPRIO=""
IF PRBIEN]""
Begin DoDot:1
+104 NEW PRIEN
+105 SET PRIEN=$ORDER(^BGOPROB("B",PRBIEN,""))
IF PRIEN=""
QUIT
+106 SET IPRIO=$$GET1^DIQ(90362.22,PRIEN_",",.02,"I")
+107 IF IPRIO=""
SET IPRIO=0
End DoDot:1
+108 ;
+109 ;Status
+110 IF +PIPIEN
SET XSTS=$$GET1^DIQ(90680.01,PIPIEN_",",.08,"E")
+111 IF '$TEST
SET XSTS=""
+112 ;
+113 ;Scope
+114 IF +PIPIEN
SET XSCO=$$GET1^DIQ(90680.01,PIPIEN_",",.07,"E")
+115 IF '$TEST
SET XSCO=""
+116 ;
+117 ;Class
+118 SET CLASS=$$GET1^DIQ(9000011,PRBIEN_",",.04,"I")
+119 ;
+120 ;Last Modified Date
+121 SET XLMDT=$$FMTE^BJPNPRL($$GET1^DIQ(9000011,PRBIEN_",",.03,"I"))
+122 ;
+123 ;Last Modified By
+124 SET XLMBY=$$GET1^DIQ(9000011,PRBIEN_",",.14,"E")
+125 ;
+126 ;IPL Status - Convert manually lower case can be displayed
+127 SET IPLSTS=$PIECE(API,U,6)
+128 IF IPLSTS=""
SET IPLSTS=$$GET1^DIQ(9000011,PRBIEN_",",.12,"E")
+129 SET IPLSTS=$SELECT(IPLSTS="CHRONIC":"Chronic",IPLSTS="INACTIVE":"Inactive",IPLSTS="D":"DELETED",IPLSTS="SUB-ACUTE":"Sub-Acute",IPLSTS="EPISODIC":"Episodic",IPLSTS="SOCIAL":"Social",IPLSTS="ROUTINE/ADMIN":"Admin",1:"")
+130 ;
+131 ;ICD Information - Pull primary and additional ICD values
+132 SET ICD=$PIECE(API,U,9)
+133 SET ADDICD=$PIECE(API,U,13)
+134 IF ADDICD]""
FOR ICDCNT=1:1:$LENGTH(ADDICD,"|")
SET ADICD=$PIECE(ADDICD,"|",ICDCNT)
IF ADICD]""
SET ICD=ICD_$SELECT(ICD]"":"|",1:"")_ADICD
+135 ;
+136 ;ICD Hover field - Not used for problem add/edit
+137 SET HICD=""
+138 ;
+139 ;Provider Text
+140 SET PNARR=$PIECE(API,U,8)
+141 SET PTEXT=$PIECE(PNARR," | ",2)
+142 ;
+143 ;Get latest Goal note
+144 SET GGO=$ORDER(@TMP@("G",PRBIEN,""))
+145 SET GOAL=""
IF GGO]""
SET GOAL=$PIECE($GET(@TMP@("G",PRBIEN,GGO,1)),U,2)
+146 ;
+147 ;Get latest Care Plan note
+148 SET CGO=$ORDER(@TMP@("C",PRBIEN,""))
+149 SET CARE=""
IF CGO]""
SET CARE=$PIECE($GET(@TMP@("C",PRBIEN,CGO,1)),U,2)
+150 ;
+151 ;Get latest V Visit Instruction
+152 SET VGO=$ORDER(@TMP@("I",PRBIEN,""))
+153 SET INST=""
IF VGO]""
SET INST=$PIECE($GET(@TMP@("I",PRBIEN,VGO,1)),U,2)
+154 ;
+155 ;Visit POV
+156 SET (IPOV,POV,ITYPE)=""
IF VIEN]""
Begin DoDot:1
+157 SET ITYPE=$$GET1^DIQ(9000010,VIEN_",",.07,"I")
IF ITYPE=""
QUIT
+158 SET ITYPE=$SELECT(ITYPE="H":"H",1:"A")
+159 IF $ORDER(^AUPNPROB(PRBIEN,14,"B",VIEN,""))
SET POV="Y"
+160 IF $ORDER(^AUPNPROB(PRBIEN,15,"B",VIEN,""))
SET IPOV="Y"
End DoDot:1
+161 ;
+162 ;Get Primary/Secondary value
+163 SET PRIMARY=$PIECE(API,U,30)
+164 ;
+165 ;Get V POV IEN
+166 SET PVIEN=$PIECE(API,U,31)
+167 ;
+168 ;Get the Episodicity
+169 SET EP=$PIECE(API,U,32)
+170 SET EPSMD=$$VALTERM^BSTSAPI("EVAR",EP_"^^1")
+171 SET EPSMD=$GET(EVAR(1,"CON"))
+172 ;
+173 ;Get the injury revisit
+174 SET INJREV=$PIECE(API,U,33)
+175 ;
+176 ;Get the injury place
+177 SET INJPLC=$PIECE(API,U,34)
+178 ;
+179 ;Get the injury date
+180 SET INJDT=$PIECE(API,U,35)
+181 ;
+182 SET INJASS=$PIECE(API,U,38)
+183 SET INJCIEN=""
IF PVIEN]""
SET INJCIEN=$$GET1^DIQ(9000010.07,PVIEN_",",.09,"I")
+184 SET INJCCOD=$PIECE(API,U,37)
+185 SET INJCDSC=$PIECE(API,U,36)
+186 SET INJCHK=""
IF (INJPLC]"")!(INJCCOD]"")!(INJCDSC]"")!(INJASS]"")!(INJCIEN]"")!(INJDT]"")
SET INJCHK="Y"
+187 ;
+188 ;Definitive EDD
+189 IF +PIPIEN
SET DEDD=$$FMTE^BJPNPRL($$GET1^DIQ(90680.01,PIPIEN_",",.09,"I"))
+190 IF '$TEST
SET DEDD=""
+191 ;
+192 ;PRV fields
+193 SET (PRV,XPRV)=""
+194 SET PRV=$$PPRV^BJPNPKL(VIEN)
+195 IF PRV]""
SET XPRV=$$GET1^DIQ(200,PRV_",",.01,"E")
+196 ;
+197 ;Qualifiers - Loop through entries and assemble
+198 SET QUAL=""
SET BGO=""
FOR
SET BGO=$ORDER(@TMP@("Q",PRBIEN,BGO))
IF BGO=""
QUIT
Begin DoDot:1
+199 ;
+200 NEW STR,N
+201 SET N=$GET(@TMP@("Q",PRBIEN,BGO,0))
+202 ;Return: TYPE (C/S) [1] 29 IEN [2] 29 CONCID [3] 29 TERM [4] 29 LMDT [5] 29 LMBY [6]
+203 SET STR=$PIECE(N,U,2)_$CHAR(29)_$PIECE(N,U,3)_$CHAR(29)_$PIECE(N,U,4)_$CHAR(29)_$PIECE(N,U,5)_$CHAR(29)_$CHAR(29)
+204 ;
+205 ;If IEN is populated and severity - get last modified by
+206 IF +$PIECE(N,U,3)
IF $PIECE(N,U,2)="S"
Begin DoDot:2
+207 NEW DA,IENS,BY,LMDT,LMBY
+208 SET DA(1)=PRBIEN
SET DA=$PIECE(N,U,3)
SET IENS=$$IENS^DILF(.DA)
+209 SET LMDT=$$GET1^DIQ(9000011.13,IENS,.05,"I")
+210 SET LMBY=$$GET1^DIQ(9000011.13,IENS,.04,"I")
+211 IF LMDT=""
Begin DoDot:3
+212 SET LMDT=$$GET1^DIQ(9000011.13,IENS,.03,"I")
+213 SET LMBY=$$GET1^DIQ(9000011.13,IENS,.02,"I")
End DoDot:3
+214 SET $PIECE(STR,$CHAR(29),5)=LMBY
+215 SET $PIECE(STR,$CHAR(29),6)=LMDT
End DoDot:2
+216 ;
+217 SET QUAL=QUAL_$SELECT(QUAL="":"",1:$CHAR(28))_STR
End DoDot:1
+218 ;
+219 ;Asthma
+220 SET ASTHMA=""
SET BGO=$ORDER(@TMP@("A",PRBIEN,""))
IF BGO]""
Begin DoDot:1
+221 SET ASTHMA=$TRANSLATE($GET(@TMP@("A",PRBIEN,BGO,0)),"^",$CHAR(29))
End DoDot:1
+222 ;
+223 ;Abnormal Findings
+224 SET ABN=$PIECE(API,U,39)
+225 ;
+226 ;BJPN*2.0*7;Added laterality
+227 ;Prompt for laterality
SET PLAT=$PIECE(API,U,19)
SET PLAT=$SELECT(PLAT=1:"Y",1:"N")
+228 SET ILAT=$PIECE(API,U,20)
+229 SET ELAT=""
IF $TRANSLATE(ILAT,"|")]""
SET ELAT=$$CVPARM^BSTSMAP1("LAT",$PIECE(ILAT,"|"))_"|"_$$CVPARM^BSTSMAP1("LAT",$PIECE(ILAT,"|",2))
+230 ;
+231 ;BJPN*2.0*9;Added Fracture Healing
+232 SET FRACT=$PIECE(API,U,40)
+233 ;
+234 ;Set up entry
+235 SET II=II+1
SET @DATA@(II)=PIPIEN_U_PRBIEN_U_XPRI_U_XSTS_U_XSCO_U_DESCID_U_DESCTM_U_CONCID_U_IPRIO_U_CLASS_U_XLMDT_U_XLMBY_U_IPLSTS
+236 SET @DATA@(II)=@DATA@(II)_U_ICD_U_HICD_U_PTEXT_U_PNARR_U_GOAL_U_CARE_U_INST_U_PRV_U_XPRV
+237 SET @DATA@(II)=@DATA@(II)_U_DEDD_U_POV_U_IPOV_U_PRIMARY_U_ITYPE_U_ONSET_U_LOC_U_EPROB
+238 SET @DATA@(II)=@DATA@(II)_U_IPROB_U_PVIEN_U_ASTHMA_U_EP_U_EPSMD_U_INJREV_U_INJPLC_U_INJDT
+239 SET @DATA@(II)=@DATA@(II)_U_INJASS_U_INJCIEN_U_INJCCOD_U_INJCDSC_U_INJCHK_U_QUAL_U_ABN_U_PLAT_U_ILAT_U_ELAT_U_FRACT
+240 SET @DATA@(II)=@DATA@(II)_$CHAR(30)
+241 ;
XPROB SET II=II+1
SET @DATA@(II)=$CHAR(31)
+1 QUIT
+2 ;
SUBSET(DATA,SUBSET) ;EP - BJPN GET SUBSET
+1 ;
+2 ;This RPC accepts a SNOMED subset value and returns the entries in the subset
+3 ;
+4 ;Input parameter:
+5 ; SUBSET - The SNOMED subset to look up and return a list of members
+6 ;
+7 NEW CNT,UID,II,RET,OUT
+8 ;
+9 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+10 SET DATA=$NAME(^TMP("BJPNSPRB",UID))
+11 KILL @DATA
+12 IF $GET(DT)=""!($GET(U)="")
DO DT^DICRW
+13 ;
+14 SET II=0
+15 ; SAC 2009 2.2.3.17
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BJPNSPRB D UNWIND^%ZTER"
+16 ;
+17 ;Define Header
+18 SET @DATA@(0)="T00300TEXT^T00025DESC_ID^T00025CONC_ID"_$CHAR(30)
+19 ;
+20 ;Input checks
+21 IF $GET(SUBSET)=""
SET BMXSEC="Missing Subset"
GOTO XSUBSET
+22 ;
+23 ;Call EHR API to retrieve the list of information
+24 SET OUT="RET"
+25 ;
+26 ;Default to local search
+27 SET $PIECE(SUBSET,U,3)=1
+28 ;
+29 DO SUBLST^BSTSAPI(OUT,SUBSET)
+30 ;
+31 ;Loop through results and output
+32 SET CNT=""
FOR
SET CNT=$ORDER(RET(CNT))
IF CNT=""
QUIT
Begin DoDot:1
+33 NEW N
+34 SET N=$GET(RET(CNT))
+35 SET II=II+1
SET @DATA@(II)=$PIECE(N,U,3)_U_$PIECE(N,U,2)_U_$PIECE(N,U)_$CHAR(30)
End DoDot:1
+36 ;
XSUBSET SET II=II+1
SET @DATA@(II)=$CHAR(31)
+1 QUIT
+2 ;
ERR ;
+1 DO ^%ZTER
+2 NEW Y,ERRDTM
+3 SET Y=$$NOW^XLFDT()
XECUTE ^DD("DD")
SET ERRDTM=Y
+4 SET II=II+1
SET @DATA@(II)=$CHAR(31)
+5 QUIT
