BJPNSPRB.m

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=""