BJPNUTIL ;GDIT/HS/BEE-Prenatal Care Module Utility Calls ; 08 May 2012 12:00 PM
;;2.0;PRENATAL CARE MODULE;**6,7,8,9**;Feb 24, 2015;Build 12
;
Q
;
GETCOI(DATA,TEXT,VIEN,COUNT) ;BJPN SELECT INJURY CAUSE
;
;Accept search string, return list of matching Cause of Injury values to choose
;Uses call to Lexicon to generate list
;
;Input
; TEXT - String to search on
; VIEN - Visit IEN
;COUNT - Number records to return (optional - default to 25)
;
NEW UID,II,VDT,SEX,DFN,RET
;
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BJPNUTIL",UID))
K @DATA
I $G(DT)=""!($G(U)="") D DT^DICRW
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BJPNUTIL D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
;
;Define header
S @DATA@(0)="I00010IEN^T00020CODE^T00200DESCRIPTION"_$C(30)
;
I $G(TEXT)="" S BMXSEC="Missing text to search on" G XGETCOI
I $G(VIEN)="" S BMXSEC="Missing Visit IEN" G XGETCOI
S:'+$G(COUNT) COUNT=25
;
;Get visit date and gender
S VDT=$P($$GET1^DIQ(9000010,VIEN_",",.01,"I"),".") S:VDT="" VDT=DT
S DFN=$$GET1^DIQ(9000010,VIEN_",",.05,"I")
S SEX=$$GET1^DIQ(2,DFN_",",.02,"I")
;
;Make call
D LEX(TEXT,COUNT,1,VDT,SEX,.RET)
S RET="" F S RET=$O(RET(RET)) Q:RET="" S II=II+1,@DATA@(II)=RET(RET)_$C(30)
;
XGETCOI S II=II+1,@DATA@(II)=$C(31)
Q
;
LEX(SEARCH,COUNT,FILTER,DATE,GENDER,RET) ;EP - Perform Lexicon Lookup
;
; SEARCH - String to search on (Required)
; COUNT - Number records to return (Optional) - Def 999
; FILTER - 0 - Regular Search - Filter out Cause of Injury Codes (Default)
; 1 - Cause of Injury Search - Return only Cause of Injury Codes
; 2 - Full Search - Return all results - no filtering
; DATE - Date to search on (def to today)
; GENDER - Patient gender (M/F/U) (Optional)
; RET - Return array
;
;Input checks
I $G(SEARCH)="" Q
S COUNT=$G(COUNT) S:'+COUNT COUNT=999
S FILTER=$G(FILTER) S:FILTER="" FILTER=0
S DATE=$G(DATE) S:DATE="" DATE=DT
S GENDER=$G(GENDER)
;
NEW ICD10,CSET,DIC,AUPNSEX,LEX,DELIMITER,DPLIST,TOTREC,ICD
;
K ^TMP("LEXSCH"),^TMP("LEXFND"),LEX("LIST")
;
;Set gender variable used in filtering call
S:($G(GENDER)]"") AUPNSEX=GENDER
;
;Determine if ICD-10
S ICD10=0 I $$VERSION^XPDUTL("AICD")>3.51,$$IMP^ICDEXA(30)'>DATE S ICD10=1
S CSET=$S(ICD10=0:"ICD",1:"10D")
;
D CONFIG^LEXSET(CSET,CSET,DATE)
;
;Choose filter
S DIC("S")="I $$FILTER^BJPNUTIL(+Y,LEXVDT,$G(ICD10),$G(FILTER))"
;
;Search
D LOOK^LEXA(SEARCH,$G(CSET),$G(COUNT),$G(CSET),$G(DATE))
;
;Determine delimiter
S DELIMITER=$S(ICD10=0:"ICD-9-CM ",1:"ICD-10-CM ")
;
S TOTREC=0,LEX="0" F S LEX=$O(LEX("LIST",LEX)) Q:LEX="" D
. I '+LEX Q
. NEW CODE,LIEN,DIEN,DESC
. ;
. ;Get code
. S CODE=$P($P(LEX("LIST",LEX),DELIMITER,2),")")
. ;
. ;Look for code in file 80
. I $$AICD() S ICD=$$ICDDX^ICDEX(CODE)
. E S ICD=$$ICDDX^ICDCODE(CODE)
. ;
. ;Tack on period
. I $P(ICD,U)="-1",CODE'["." D
.. S CODE=CODE_"."
.. I $$AICD() S ICD=$$ICDDX^ICDEX(CODE)
.. E S ICD=$$ICDDX^ICDCODE(CODE)
. ;
. ;Filter out duplicates
. I $D(DPLIST(CODE)) Q
. ;
. ;Not found
. I $P(ICD,U)="-1" Q
. ;
. ;Create entry
. S DIEN=$P(ICD,U) Q:DIEN=""
. S CODE=$P(ICD,U,2)
. S DESC=$P(ICD,U,4)
. S TOTREC=TOTREC+1,RET(TOTREC)=DIEN_U_CODE_U_DESC
. S DPLIST(CODE)=""
Q
;
;Filter on Cause of Injury
FILTER(ALEX,ALEXVDT,ICD10,FILTER) ;Filtering for Lexicon lookup
;
;Input parameters
; ALEX - IEN of file 757.01
; ALEXVDT - Date to use for screening by codes
; ICD10 - 1 - ICD10, 0 - ICD9
; FILTER - 0 - No Cause of Injury, 1 - Only Cause of Injury, 2 - All codes
;
NEW RETURN,APCDDATE
;
;Default to return
S RETURN=1
;
;For FILTER equal 2 - Return all
I $G(FILTER)=2 Q RETURN
;
;ICD9 - Filter 0
I FILTER=0,ICD10=0 D Q RETURN
. N ALEXICD
. S ALEXVDT=$S(+$G(ALEXVDT)>0:ALEXVDT,1:$$DT^XLFDT)
. S ALEX=$$ICDONE^LEXU(ALEX,ALEXVDT) I ALEX="" S RETURN="" Q
. S ALEXICD=$$ICDDX^AUPNVUTL(ALEX,ALEXVDT,"E")
. I $P(ALEXICD,"^",2)="INVALID CODE" S RETURN="" Q
. S APCDDATE=ALEXVDT
. I '$$CHK^AUPNSICD($P(ALEXICD,U,1)) S RETURN="" Q
;
;ICD10 - Filter 0
I FILTER=0,ICD10=1 D Q RETURN
. N ALEXICD
. S ALEX=$$ONE^LEXU(ALEX,ALEXVDT,"10D") I ALEX="" S RETURN="" Q
. S ALEXICD=$$ICDDX^AUPNVUTL(ALEX,ALEXVDT,"E")
. I $P(ALEXICD,"^",2)="INVALID CODE" S RETURN="" Q
. S APCDDATE=ALEXVDT
. I '$$CHK^AUPNSICD($P(ALEXICD,U,1)) S RETURN="" Q
;
;Both ICD9/ICD10 - Filter 1
I FILTER=1 D Q RETURN
. N ALEXICD,ALEVXDT,%
. S ALEX=$$ONE^LEXU(ALEX,ALEXVDT,$S(ICD10=1:"10D",1:"ICD")) I ALEX="" S RETURN="" Q
. S ALEXICD=$$ICDDX^AUPNVUTL(ALEX,ALEXVDT,"E")
. I $P(ALEXICD,"^",2)="INVALID CODE" S RETURN="" Q
. I '$$CHK^BJPNUTIL($P(ALEXICD,U,1),ICD10,ALEXVDT) S RETURN="" Q
;
Q
;
CHK(Y,ICD10,ALEXVDT) ;EP - SCREEN NON CAUSE OF INJURY AND INACTIVE CODES
NEW A,I,%
I $G(DUZ("AG"))'="I" Q 1
S:ALEXVDT="" ALEXVDT=DT
S I=$S($G(ICD10)=0:1,1:30)
S %=$$ICDDX^AUPNVUTL(Y,ALEXVDT) I 1
I $P(%,U,20)]"",$P(%,U,20)'=I Q 0 ;not correct coding system
S I="CHKDX"_I
G @I
;
CHKDX1 ;CODING SYSTEM 1 - ICD9
;
;Only return E codes
I $E($P(%,U,2),1)'="E" Q 0
;
;Skip inactive codes
I '$P(%,U,10) Q 0 ;INACTIVE
;
;If 'USE WITH SEX' field has value check that value against AUPNSEX
I '$D(AUPNSEX) Q 1
I $P(%,U,11)]"",$P(%,U,11)'=AUPNSEX Q 0
Q 1
;
CHKDX30 ;coding system 30-ICD10
NEW RET
S RET=0
I $E($P(%,U,2),1)="V" S RET=1
I 'RET,$E($P(%,U,2),1)="W" S RET=1
I 'RET,$E($P(%,U,2),1)="X" S RET=1
I 'RET,$E($P(%,U,2),1)="Y" D
. NEW EXC
. S EXC=$E($P(%,U,2),1,3)
. ;
. ;Handle exceptions to list
. I EXC'="Y92",EXC'="Y93" S RET=1
. S RET=0
;
I '$P(%,U,10) S RET=0 ;STATUS IS INACTIVE
;
;If 'USE WITH SEX' field has value check against AUPNSEX
I '$D(AUPNSEX) Q RET
I $P(%,U,11)]"",$P(%,U,11)'=AUPNSEX S RET=0
Q RET
;
AICD() ;EP - Return 1 if AICD 4.0
Q $S($$VERSION^XPDUTL("AICD")="4.0":1,1:0)
;
LOG(BJPNCAT,BJPNACT,BJPNCALL,BJPNDESC,BJPNVDFN) ;EP - Log Prenatal Audit entry
;
NEW BJPNDFN,X,RES
;
;See if BUSA has been installed
S X="BUSAAPI" X ^%ZOSF("TEST") I '$T Q "BUSA has not been installed"
;
;Check input
I ",S,P,D,O,"'[(","_$G(BJPNCAT)_",") Q "Invalid Audit Category"
I (BJPNCAT="P"),(",A,D,Q,P,E,C,"'[(","_$G(BJPNACT)_",")) Q "Invalid Audit Action"
I $G(BJPNDESC)="" Q "Invalid Audit Log Description"
S:$G(BJPNCALL)="" BJPNCALL="AMER Audit API Call"
;
;Handle single patients passed in
I $D(BJPNVDFN)=1,$G(BJPNVDFN)]"" D
. S BJPNDFN(1)=BJPNVDFN
;
;Handle multiple patients passed in
I $D(BJPNVDFN)>9 D
. NEW II,CNT
. S II="",CNT=0 F S II=$O(BJPNVDFN(II)) Q:II="" S CNT=CNT+1,BJPNDFN(CNT)=BJPNVDFN(II)
;
;Perform audit call
S RES=$$LOG^BUSAAPI("A",BJPNCAT,BJPNACT,BJPNCALL,BJPNDESC,"BJPNDFN")
Q RES
;
ASTHMA(DATA,CODE,SNOMED) ;EP - BJPN CHECK FOR ASTHMA
;
NEW UID,II,RET
;
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BJPNUTIL",UID))
K @DATA
I $G(DT)=""!($G(U)="") D DT^DICRW
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BJPNUTIL D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
;
;Define header
S @DATA@(0)="I00001RESULT"_$C(30)
;
I $G(CODE)="",$G(SNOMED)="" S BMXSEC="Both ICD code and SNOMED cannot be null" G XASTHMA
;
;Call MSC to perform check
D CHKASM^BGOASLK(.RET,$G(CODE),$G(SNOMED))
S II=II+1,@DATA@(II)=+$G(RET)_$C(30)
;
XASTHMA S II=II+1,@DATA@(II)=$C(31)
Q
;
ISINJ(DATA,SNOMED,VIEN) ;EP - BJPN CHECK FOR INJURY
;
NEW UID,II,RET
;
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BJPNUTIL",UID))
K @DATA
I $G(DT)=""!($G(U)="") D DT^DICRW
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BJPNUTIL D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
;
;Define header
S @DATA@(0)="I00001RESULT"_$C(30)
;
I $G(SNOMED)="" S BMXSEC="Missing Concept Id" G XISINJ
I $G(VIEN)="" S BMXSEC="Missing VIEN" G XISINJ
;
;Call MSC to perform check
D INJURY^BGOVPOV2(.RET,SNOMED,VIEN)
S II=II+1,@DATA@(II)=+$G(RET)_$C(30)
;
XISINJ S II=II+1,@DATA@(II)=$C(31)
Q
;
ASTCLS(DATA,FAKE) ;EP - BJPN GET ASTHMA CLASSES
;
NEW UID,II
;
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BJPNUTIL",UID))
K @DATA
I $G(DT)=""!($G(U)="") D DT^DICRW
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BJPNUTIL D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
;
;Define header
S @DATA@(0)="T00050ASTHMA_CLASSIFICATIONS"_$C(30)
;
;Hardset entries
S II=II+1,@DATA@(II)="INTERMITTENT"_$C(30)
S II=II+1,@DATA@(II)="MILD PERSISTENT"_$C(30)
S II=II+1,@DATA@(II)="MODERATE PERSISTENT"_$C(30)
S II=II+1,@DATA@(II)="SEVERE PERSISTENT"_$C(30)
;
XASTCLS S II=II+1,@DATA@(II)=$C(31)
Q
;
ASTCON(DATA,FAKE) ;EP - BJPN GET ASTHMA CONTROL
;
NEW UID,II
;
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BJPNUTIL",UID))
K @DATA
I $G(DT)=""!($G(U)="") D DT^DICRW
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BJPNUTIL D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
;
;Define header
S @DATA@(0)="T00050ASTHMA_CONTROL"_$C(30)
;
;Hardset entries
S II=II+1,@DATA@(II)="WELL CONTROLLED"_$C(30)
S II=II+1,@DATA@(II)="NOT WELL CONTROLLED"_$C(30)
S II=II+1,@DATA@(II)="VERY POORLY CONTROLLED"_$C(30)
;
XASTCON S II=II+1,@DATA@(II)=$C(31)
Q
;
INJPLC(DATA,FAKE) ;EP - BJPN GET INJURY PLACE LIST
;
NEW UID,II
;
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BJPNUTIL",UID))
K @DATA
I $G(DT)=""!($G(U)="") D DT^DICRW
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BJPNUTIL D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
;
;Define header
S @DATA@(0)="T00005INJ_PLACE_CD^T00050INJURY_PLACE"_$C(30)
;
;Hardset entries
S II=II+1,@DATA@(II)="A^HOME-INSIDE"_$C(30)
S II=II+1,@DATA@(II)="B^HOME-OUTSIDE"_$C(30)
S II=II+1,@DATA@(II)="C^FARM"_$C(30)
S II=II+1,@DATA@(II)="D^SCHOOL"_$C(30)
S II=II+1,@DATA@(II)="E^INDUSTRIAL PREMISES"_$C(30)
S II=II+1,@DATA@(II)="F^RECREATIONAL AREA"_$C(30)
S II=II+1,@DATA@(II)="G^STREET/HIGHWAY"_$C(30)
S II=II+1,@DATA@(II)="H^PUBLIC BUILDING"_$C(30)
S II=II+1,@DATA@(II)="I^RESIDENT INSTITUTION"_$C(30)
S II=II+1,@DATA@(II)="J^HUNTING/FISHING"_$C(30)
S II=II+1,@DATA@(II)="K^OTHER"_$C(30)
S II=II+1,@DATA@(II)="L^UNKNOWN"_$C(30)
;
XINJPLC S II=II+1,@DATA@(II)=$C(31)
Q
;
DXCAUSE(DATA,FAKE) ;EP - BJPN GET DX CAUSE
;
NEW UID,II,RET,ARR
;
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BJPNUTIL",UID))
K @DATA
I $G(DT)=""!($G(U)="") D DT^DICRW
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BJPNUTIL D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
;
;Define header
S @DATA@(0)="T00010CODE^T00050DX_CAUSE"_$C(30)
;
D GETSET^BGOUTL3(.RET,9000010.07,.07)
;
S ARR="" F S ARR=$O(RET(ARR)) Q:ARR="" S II=II+1,@DATA@(II)=$P(RET(ARR),U)_U_$P(RET(ARR),U,2)_$C(30)
;
XDXCAUSE S II=II+1,@DATA@(II)=$C(31)
Q
;
COMP(DFN,UID,VIEN,PRBIEN) ;EP - Call EHR API and format results into usable data
;
NEW RET,TMP,T,BGO,LAT
;
;If no problem passed in get all
I $G(PRBIEN)="" D GET^BGOPROB(.RET,DFN,"ASEORPI","A",99999,2)
;
;If problem passed in, get one
I +$G(PRBIEN) D GETONE^BGOPROB1(.RET,+PRBIEN,2)
;
;Reset compile global - data to be used by this call and future RPC calls
K ^TMP("BJPNIPL",UID)
;
;Populate info
S TMP=$NA(^TMP("BJPNIPL",UID))
S (T,BGO)="" F S BGO=$O(@RET@(BGO)) Q:BGO="" D
. NEW N
. S N=$G(@RET@(BGO))
. S P=$G(P)
. I $P(N,U)="P" S P=$P(N,U,2) S:P]"" B=BGO,@TMP@("P",P,B)=N,T="P" Q ;Problems
. I $P(N,U)="C" S P=$P(N,U,3) S:P]"" B=BGO,@TMP@("C",P,B,0)=N,T="C" Q ;Care Plans
. I $P(N,U)="G" S P=$P(N,U,3) S:P]"" B=BGO,@TMP@("G",P,B,0)=N,T="G" Q ;Goals
. I $P(N,U)="I" S P=$P(N,U,3) S:P]"" B=BGO,@TMP@("I",P,B,0)=N,T="I" Q ;Visit Instructions
. I $P(N,U)="O" S P=$P(N,U,3) S:P]"" B=BGO,@TMP@("O",P,B,0)=N,T="O" Q ;OB Note
. I $P(N,U)="T" S P=$P(N,U,4) S:P]"" B=BGO,@TMP@("T",P,B,0)=N,T="T" Q ;Treatment Regimen
. I $P(N,U)="E" S:P]"" B=BGO,@TMP@("E",P,B,0)=$$PTED^BJPNPUTL(N) ;Education
. I $P(N,U)="A" S:P]"" B=BGO,@TMP@("A",P,B,0)=N ;Asthma
. I $P(N,U)="Q" S:P]"" B=BGO,@TMP@("Q",P,B,0)=N ;Qualifiers
. ;
. ;C/G/I/O/T Text
. I $E(N,1)="~",P]"",T]"",B]"" S @TMP@(T,P,B,$O(@TMP@(T,P,B,""),-1)+1)=N
;
;Get POVs
I $G(VIEN)]"" D
. NEW FNDPS,PVLST,FINFO
. S PVLST=""
. D GET^BGOVPOV(.RET,VIEN)
. S BGO="" F S BGO=$O(@RET@(BGO)) Q:BGO="" D
.. NEW N,P,PS,PENT,B,PVIEN,RETDATA
.. S N=$G(@RET@(BGO))
.. S P=$P(N,U,24) ;Problem
.. ;
.. Q:P="" ;Quite if no problem
.. Q:'$D(@TMP@("P",P)) ;Quit if not in list
.. S B=$O(@TMP@("P",P,"")) Q:B="" ;Quit if no entry
.. ;
.. S PS=$P(N,U,16) ;Primary/Secondary
.. I PS="PRIMARY" S FNDPS(P)="Y"
.. S PVIEN=$P(N,U) ;POV IEN
.. I PVIEN]"" S PVLST=PVLST_$S(PVLST]"":$C(29),1:"")_PVIEN
.. ;
.. ;Look for episodicity and injury info
.. I $G(FINFO(P))="" D
... NEW EP,REV,INJCASS,PLC,INJDT,INJCEXT,INJCINT,AF,FRACT
... S EP=$P(N,U,6) S:EP]"" FINFO(P)=1 ;Episodicity
... S REV=$P(N,U,11) S:REV]"" FINFO(P)=1 ;Injury Revisit
... S INJCASS=$P(N,U,12) S:INJCASS]"" FINFO(P)=1 ;Inj Association
... S PLC=$P($P(N,U,15),"~") S:PLC]"" FINFO(P)=1 ;Inj Place
... S INJDT=$P(N,U,13) S:INJDT]"" FINFO(P)=1 ;Injury Date
... S INJCEXT=$P(N,U,14) S:INJCEXT]"" FINFO(P)=1 ;Ext Inj Cause
... S INJCINT=$P(N,U,25) S:INJCINT]"" FINFO(P)=1 ;Int Inj Cause
... ;BJPN*2.0*6;Include abnormal findings
... S AF=$P($P(N,U,28),";")
... S:AF]"" AF=$O(^BSTS(9002318.6,"C","AF",AF,""))
... S:AF]"" FINFO(P)=1 ;Abnormal Findings
... ;BJPN*2.0*9;Include Fracture
... S FRACT=$P(N,U,30)
... S FINFO(P,"FRACT")=FRACT
... S FINFO(P,"AF")=AF
... S FINFO(P,"EP")=EP
... S FINFO(P,"REV")=REV
... S FINFO(P,"INJCASS")=INJCASS
... S FINFO(P,"PLC")=PLC
... S FINFO(P,"INJDT")=INJDT
... S FINFO(P,"INJCEXT")=INJCEXT
... S FINFO(P,"INJCINT")=INJCINT
.. ;
.. ;BJPN*2.0*9;Added fracture in 40
.. ;Set the Primary/Secondary,POV IEN, Episodicity in the problem entry
.. S RETDATA=$G(FNDPS(P))_U_PVLST_U_$G(FINFO(P,"EP"))_U_$G(FINFO(P,"REV"))_U_$G(FINFO(P,"PLC"))
.. S RETDATA=RETDATA_U_$G(FINFO(P,"INJDT"))_U_$G(FINFO(P,"INJCEXT"))_U_$G(FINFO(P,"INJCINT"))_U_$G(FINFO(P,"INJCASS"))_U_$G(FINFO(P,"AF"))_U_$G(FINFO(P,"FRACT"))
.. S $P(@TMP@("P",P,B),U,30,40)=RETDATA
;
Q
;
INJURY(DATA,CODE,SNOMED) ;EP - BJPN INJURY CHECK
;
NEW UID,II,RET
;
S UID=$S($G(ZTSK):"Z"_ZTSK,1:$J)
S DATA=$NA(^TMP("BJPNUTIL",UID))
K @DATA
I $G(DT)=""!($G(U)="") D DT^DICRW
;
S II=0
NEW $ESTACK,$ETRAP S $ETRAP="D ERR^BJPNUTIL D UNWIND^%ZTER" ; SAC 2009 2.2.3.17
;
;Define header
S @DATA@(0)="I00001RESULT"_$C(30)
;
I $G(CODE)="" S BMXSEC="Missing ICD code value" G XINJURY
I $G(SNOMED)="" S BMXSEC="Missing SNOMED code" G XINJURY
;
;Call MSC to perform check
D CHKASM^BGOASLK(.RET,CODE,SNOMED)
S II=II+1,@DATA@(II)=+$G(RET)_$C(30)
;
XINJURY 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
Q
BJPNUTIL ;GDIT/HS/BEE-Prenatal Care Module Utility Calls ; 08 May 2012 12:00 PM
+1 ;;2.0;PRENATAL CARE MODULE;**6,7,8,9**;Feb 24, 2015;Build 12
+2 ;
+3 QUIT
+4 ;
GETCOI(DATA,TEXT,VIEN,COUNT) ;BJPN SELECT INJURY CAUSE
+1 ;
+2 ;Accept search string, return list of matching Cause of Injury values to choose
+3 ;Uses call to Lexicon to generate list
+4 ;
+5 ;Input
+6 ; TEXT - String to search on
+7 ; VIEN - Visit IEN
+8 ;COUNT - Number records to return (optional - default to 25)
+9 ;
+10 NEW UID,II,VDT,SEX,DFN,RET
+11 ;
+12 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+13 SET DATA=$NAME(^TMP("BJPNUTIL",UID))
+14 KILL @DATA
+15 IF $GET(DT)=""!($GET(U)="")
DO DT^DICRW
+16 ;
+17 SET II=0
+18 ; SAC 2009 2.2.3.17
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BJPNUTIL D UNWIND^%ZTER"
+19 ;
+20 ;Define header
+21 SET @DATA@(0)="I00010IEN^T00020CODE^T00200DESCRIPTION"_$CHAR(30)
+22 ;
+23 IF $GET(TEXT)=""
SET BMXSEC="Missing text to search on"
GOTO XGETCOI
+24 IF $GET(VIEN)=""
SET BMXSEC="Missing Visit IEN"
GOTO XGETCOI
+25 IF '+$GET(COUNT)
SET COUNT=25
+26 ;
+27 ;Get visit date and gender
+28 SET VDT=$PIECE($$GET1^DIQ(9000010,VIEN_",",.01,"I"),".")
IF VDT=""
SET VDT=DT
+29 SET DFN=$$GET1^DIQ(9000010,VIEN_",",.05,"I")
+30 SET SEX=$$GET1^DIQ(2,DFN_",",.02,"I")
+31 ;
+32 ;Make call
+33 DO LEX(TEXT,COUNT,1,VDT,SEX,.RET)
+34 SET RET=""
FOR
SET RET=$ORDER(RET(RET))
IF RET=""
QUIT
SET II=II+1
SET @DATA@(II)=RET(RET)_$CHAR(30)
+35 ;
XGETCOI SET II=II+1
SET @DATA@(II)=$CHAR(31)
+1 QUIT
+2 ;
LEX(SEARCH,COUNT,FILTER,DATE,GENDER,RET) ;EP - Perform Lexicon Lookup
+1 ;
+2 ; SEARCH - String to search on (Required)
+3 ; COUNT - Number records to return (Optional) - Def 999
+4 ; FILTER - 0 - Regular Search - Filter out Cause of Injury Codes (Default)
+5 ; 1 - Cause of Injury Search - Return only Cause of Injury Codes
+6 ; 2 - Full Search - Return all results - no filtering
+7 ; DATE - Date to search on (def to today)
+8 ; GENDER - Patient gender (M/F/U) (Optional)
+9 ; RET - Return array
+10 ;
+11 ;Input checks
+12 IF $GET(SEARCH)=""
QUIT
+13 SET COUNT=$GET(COUNT)
IF '+COUNT
SET COUNT=999
+14 SET FILTER=$GET(FILTER)
IF FILTER=""
SET FILTER=0
+15 SET DATE=$GET(DATE)
IF DATE=""
SET DATE=DT
+16 SET GENDER=$GET(GENDER)
+17 ;
+18 NEW ICD10,CSET,DIC,AUPNSEX,LEX,DELIMITER,DPLIST,TOTREC,ICD
+19 ;
+20 KILL ^TMP("LEXSCH"),^TMP("LEXFND"),LEX("LIST")
+21 ;
+22 ;Set gender variable used in filtering call
+23 IF ($GET(GENDER)]"")
SET AUPNSEX=GENDER
+24 ;
+25 ;Determine if ICD-10
+26 SET ICD10=0
IF $$VERSION^XPDUTL("AICD")>3.51
IF $$IMP^ICDEXA(30)'>DATE
SET ICD10=1
+27 SET CSET=$SELECT(ICD10=0:"ICD",1:"10D")
+28 ;
+29 DO CONFIG^LEXSET(CSET,CSET,DATE)
+30 ;
+31 ;Choose filter
+32 SET DIC("S")="I $$FILTER^BJPNUTIL(+Y,LEXVDT,$G(ICD10),$G(FILTER))"
+33 ;
+34 ;Search
+35 DO LOOK^LEXA(SEARCH,$GET(CSET),$GET(COUNT),$GET(CSET),$GET(DATE))
+36 ;
+37 ;Determine delimiter
+38 SET DELIMITER=$SELECT(ICD10=0:"ICD-9-CM ",1:"ICD-10-CM ")
+39 ;
+40 SET TOTREC=0
SET LEX="0"
FOR
SET LEX=$ORDER(LEX("LIST",LEX))
IF LEX=""
QUIT
Begin DoDot:1
+41 IF '+LEX
QUIT
+42 NEW CODE,LIEN,DIEN,DESC
+43 ;
+44 ;Get code
+45 SET CODE=$PIECE($PIECE(LEX("LIST",LEX),DELIMITER,2),")")
+46 ;
+47 ;Look for code in file 80
+48 IF $$AICD()
SET ICD=$$ICDDX^ICDEX(CODE)
+49 IF '$TEST
SET ICD=$$ICDDX^ICDCODE(CODE)
+50 ;
+51 ;Tack on period
+52 IF $PIECE(ICD,U)="-1"
IF CODE'["."
Begin DoDot:2
+53 SET CODE=CODE_"."
+54 IF $$AICD()
SET ICD=$$ICDDX^ICDEX(CODE)
+55 IF '$TEST
SET ICD=$$ICDDX^ICDCODE(CODE)
End DoDot:2
+56 ;
+57 ;Filter out duplicates
+58 IF $DATA(DPLIST(CODE))
QUIT
+59 ;
+60 ;Not found
+61 IF $PIECE(ICD,U)="-1"
QUIT
+62 ;
+63 ;Create entry
+64 SET DIEN=$PIECE(ICD,U)
IF DIEN=""
QUIT
+65 SET CODE=$PIECE(ICD,U,2)
+66 SET DESC=$PIECE(ICD,U,4)
+67 SET TOTREC=TOTREC+1
SET RET(TOTREC)=DIEN_U_CODE_U_DESC
+68 SET DPLIST(CODE)=""
End DoDot:1
+69 QUIT
+70 ;
+71 ;Filter on Cause of Injury
FILTER(ALEX,ALEXVDT,ICD10,FILTER) ;Filtering for Lexicon lookup
+1 ;
+2 ;Input parameters
+3 ; ALEX - IEN of file 757.01
+4 ; ALEXVDT - Date to use for screening by codes
+5 ; ICD10 - 1 - ICD10, 0 - ICD9
+6 ; FILTER - 0 - No Cause of Injury, 1 - Only Cause of Injury, 2 - All codes
+7 ;
+8 NEW RETURN,APCDDATE
+9 ;
+10 ;Default to return
+11 SET RETURN=1
+12 ;
+13 ;For FILTER equal 2 - Return all
+14 IF $GET(FILTER)=2
QUIT RETURN
+15 ;
+16 ;ICD9 - Filter 0
+17 IF FILTER=0
IF ICD10=0
Begin DoDot:1
+18 NEW ALEXICD
+19 SET ALEXVDT=$SELECT(+$GET(ALEXVDT)>0:ALEXVDT,1:$$DT^XLFDT)
+20 SET ALEX=$$ICDONE^LEXU(ALEX,ALEXVDT)
IF ALEX=""
SET RETURN=""
QUIT
+21 SET ALEXICD=$$ICDDX^AUPNVUTL(ALEX,ALEXVDT,"E")
+22 IF $PIECE(ALEXICD,"^",2)="INVALID CODE"
SET RETURN=""
QUIT
+23 SET APCDDATE=ALEXVDT
+24 IF '$$CHK^AUPNSICD($PIECE(ALEXICD,U,1))
SET RETURN=""
QUIT
End DoDot:1
QUIT RETURN
+25 ;
+26 ;ICD10 - Filter 0
+27 IF FILTER=0
IF ICD10=1
Begin DoDot:1
+28 NEW ALEXICD
+29 SET ALEX=$$ONE^LEXU(ALEX,ALEXVDT,"10D")
IF ALEX=""
SET RETURN=""
QUIT
+30 SET ALEXICD=$$ICDDX^AUPNVUTL(ALEX,ALEXVDT,"E")
+31 IF $PIECE(ALEXICD,"^",2)="INVALID CODE"
SET RETURN=""
QUIT
+32 SET APCDDATE=ALEXVDT
+33 IF '$$CHK^AUPNSICD($PIECE(ALEXICD,U,1))
SET RETURN=""
QUIT
End DoDot:1
QUIT RETURN
+34 ;
+35 ;Both ICD9/ICD10 - Filter 1
+36 IF FILTER=1
Begin DoDot:1
+37 NEW ALEXICD,ALEVXDT,%
+38 SET ALEX=$$ONE^LEXU(ALEX,ALEXVDT,$SELECT(ICD10=1:"10D",1:"ICD"))
IF ALEX=""
SET RETURN=""
QUIT
+39 SET ALEXICD=$$ICDDX^AUPNVUTL(ALEX,ALEXVDT,"E")
+40 IF $PIECE(ALEXICD,"^",2)="INVALID CODE"
SET RETURN=""
QUIT
+41 IF '$$CHK^BJPNUTIL($PIECE(ALEXICD,U,1),ICD10,ALEXVDT)
SET RETURN=""
QUIT
End DoDot:1
QUIT RETURN
+42 ;
+43 QUIT
+44 ;
CHK(Y,ICD10,ALEXVDT) ;EP - SCREEN NON CAUSE OF INJURY AND INACTIVE CODES
+1 NEW A,I,%
+2 IF $GET(DUZ("AG"))'="I"
QUIT 1
+3 IF ALEXVDT=""
SET ALEXVDT=DT
+4 SET I=$SELECT($GET(ICD10)=0:1,1:30)
+5 SET %=$$ICDDX^AUPNVUTL(Y,ALEXVDT)
IF 1
+6 ;not correct coding system
IF $PIECE(%,U,20)]""
IF $PIECE(%,U,20)'=I
QUIT 0
+7 SET I="CHKDX"_I
+8 GOTO @I
+9 ;
CHKDX1 ;CODING SYSTEM 1 - ICD9
+1 ;
+2 ;Only return E codes
+3 IF $EXTRACT($PIECE(%,U,2),1)'="E"
QUIT 0
+4 ;
+5 ;Skip inactive codes
+6 ;INACTIVE
IF '$PIECE(%,U,10)
QUIT 0
+7 ;
+8 ;If 'USE WITH SEX' field has value check that value against AUPNSEX
+9 IF '$DATA(AUPNSEX)
QUIT 1
+10 IF $PIECE(%,U,11)]""
IF $PIECE(%,U,11)'=AUPNSEX
QUIT 0
+11 QUIT 1
+12 ;
CHKDX30 ;coding system 30-ICD10
+1 NEW RET
+2 SET RET=0
+3 IF $EXTRACT($PIECE(%,U,2),1)="V"
SET RET=1
+4 IF 'RET
IF $EXTRACT($PIECE(%,U,2),1)="W"
SET RET=1
+5 IF 'RET
IF $EXTRACT($PIECE(%,U,2),1)="X"
SET RET=1
+6 IF 'RET
IF $EXTRACT($PIECE(%,U,2),1)="Y"
Begin DoDot:1
+7 NEW EXC
+8 SET EXC=$EXTRACT($PIECE(%,U,2),1,3)
+9 ;
+10 ;Handle exceptions to list
+11 IF EXC'="Y92"
IF EXC'="Y93"
SET RET=1
+12 SET RET=0
End DoDot:1
+13 ;
+14 ;STATUS IS INACTIVE
IF '$PIECE(%,U,10)
SET RET=0
+15 ;
+16 ;If 'USE WITH SEX' field has value check against AUPNSEX
+17 IF '$DATA(AUPNSEX)
QUIT RET
+18 IF $PIECE(%,U,11)]""
IF $PIECE(%,U,11)'=AUPNSEX
SET RET=0
+19 QUIT RET
+20 ;
AICD() ;EP - Return 1 if AICD 4.0
+1 QUIT $SELECT($$VERSION^XPDUTL("AICD")="4.0":1,1:0)
+2 ;
LOG(BJPNCAT,BJPNACT,BJPNCALL,BJPNDESC,BJPNVDFN) ;EP - Log Prenatal Audit entry
+1 ;
+2 NEW BJPNDFN,X,RES
+3 ;
+4 ;See if BUSA has been installed
+5 SET X="BUSAAPI"
XECUTE ^%ZOSF("TEST")
IF '$TEST
QUIT "BUSA has not been installed"
+6 ;
+7 ;Check input
+8 IF ",S,P,D,O,"'[(","_$GET(BJPNCAT)_",")
QUIT "Invalid Audit Category"
+9 IF (BJPNCAT="P")
IF (",A,D,Q,P,E,C,"'[(","_$GET(BJPNACT)_","))
QUIT "Invalid Audit Action"
+10 IF $GET(BJPNDESC)=""
QUIT "Invalid Audit Log Description"
+11 IF $GET(BJPNCALL)=""
SET BJPNCALL="AMER Audit API Call"
+12 ;
+13 ;Handle single patients passed in
+14 IF $DATA(BJPNVDFN)=1
IF $GET(BJPNVDFN)]""
Begin DoDot:1
+15 SET BJPNDFN(1)=BJPNVDFN
End DoDot:1
+16 ;
+17 ;Handle multiple patients passed in
+18 IF $DATA(BJPNVDFN)>9
Begin DoDot:1
+19 NEW II,CNT
+20 SET II=""
SET CNT=0
FOR
SET II=$ORDER(BJPNVDFN(II))
IF II=""
QUIT
SET CNT=CNT+1
SET BJPNDFN(CNT)=BJPNVDFN(II)
End DoDot:1
+21 ;
+22 ;Perform audit call
+23 SET RES=$$LOG^BUSAAPI("A",BJPNCAT,BJPNACT,BJPNCALL,BJPNDESC,"BJPNDFN")
+24 QUIT RES
+25 ;
ASTHMA(DATA,CODE,SNOMED) ;EP - BJPN CHECK FOR ASTHMA
+1 ;
+2 NEW UID,II,RET
+3 ;
+4 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+5 SET DATA=$NAME(^TMP("BJPNUTIL",UID))
+6 KILL @DATA
+7 IF $GET(DT)=""!($GET(U)="")
DO DT^DICRW
+8 ;
+9 SET II=0
+10 ; SAC 2009 2.2.3.17
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BJPNUTIL D UNWIND^%ZTER"
+11 ;
+12 ;Define header
+13 SET @DATA@(0)="I00001RESULT"_$CHAR(30)
+14 ;
+15 IF $GET(CODE)=""
IF $GET(SNOMED)=""
SET BMXSEC="Both ICD code and SNOMED cannot be null"
GOTO XASTHMA
+16 ;
+17 ;Call MSC to perform check
+18 DO CHKASM^BGOASLK(.RET,$GET(CODE),$GET(SNOMED))
+19 SET II=II+1
SET @DATA@(II)=+$GET(RET)_$CHAR(30)
+20 ;
XASTHMA SET II=II+1
SET @DATA@(II)=$CHAR(31)
+1 QUIT
+2 ;
ISINJ(DATA,SNOMED,VIEN) ;EP - BJPN CHECK FOR INJURY
+1 ;
+2 NEW UID,II,RET
+3 ;
+4 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+5 SET DATA=$NAME(^TMP("BJPNUTIL",UID))
+6 KILL @DATA
+7 IF $GET(DT)=""!($GET(U)="")
DO DT^DICRW
+8 ;
+9 SET II=0
+10 ; SAC 2009 2.2.3.17
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BJPNUTIL D UNWIND^%ZTER"
+11 ;
+12 ;Define header
+13 SET @DATA@(0)="I00001RESULT"_$CHAR(30)
+14 ;
+15 IF $GET(SNOMED)=""
SET BMXSEC="Missing Concept Id"
GOTO XISINJ
+16 IF $GET(VIEN)=""
SET BMXSEC="Missing VIEN"
GOTO XISINJ
+17 ;
+18 ;Call MSC to perform check
+19 DO INJURY^BGOVPOV2(.RET,SNOMED,VIEN)
+20 SET II=II+1
SET @DATA@(II)=+$GET(RET)_$CHAR(30)
+21 ;
XISINJ SET II=II+1
SET @DATA@(II)=$CHAR(31)
+1 QUIT
+2 ;
ASTCLS(DATA,FAKE) ;EP - BJPN GET ASTHMA CLASSES
+1 ;
+2 NEW UID,II
+3 ;
+4 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+5 SET DATA=$NAME(^TMP("BJPNUTIL",UID))
+6 KILL @DATA
+7 IF $GET(DT)=""!($GET(U)="")
DO DT^DICRW
+8 ;
+9 SET II=0
+10 ; SAC 2009 2.2.3.17
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BJPNUTIL D UNWIND^%ZTER"
+11 ;
+12 ;Define header
+13 SET @DATA@(0)="T00050ASTHMA_CLASSIFICATIONS"_$CHAR(30)
+14 ;
+15 ;Hardset entries
+16 SET II=II+1
SET @DATA@(II)="INTERMITTENT"_$CHAR(30)
+17 SET II=II+1
SET @DATA@(II)="MILD PERSISTENT"_$CHAR(30)
+18 SET II=II+1
SET @DATA@(II)="MODERATE PERSISTENT"_$CHAR(30)
+19 SET II=II+1
SET @DATA@(II)="SEVERE PERSISTENT"_$CHAR(30)
+20 ;
XASTCLS SET II=II+1
SET @DATA@(II)=$CHAR(31)
+1 QUIT
+2 ;
ASTCON(DATA,FAKE) ;EP - BJPN GET ASTHMA CONTROL
+1 ;
+2 NEW UID,II
+3 ;
+4 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+5 SET DATA=$NAME(^TMP("BJPNUTIL",UID))
+6 KILL @DATA
+7 IF $GET(DT)=""!($GET(U)="")
DO DT^DICRW
+8 ;
+9 SET II=0
+10 ; SAC 2009 2.2.3.17
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BJPNUTIL D UNWIND^%ZTER"
+11 ;
+12 ;Define header
+13 SET @DATA@(0)="T00050ASTHMA_CONTROL"_$CHAR(30)
+14 ;
+15 ;Hardset entries
+16 SET II=II+1
SET @DATA@(II)="WELL CONTROLLED"_$CHAR(30)
+17 SET II=II+1
SET @DATA@(II)="NOT WELL CONTROLLED"_$CHAR(30)
+18 SET II=II+1
SET @DATA@(II)="VERY POORLY CONTROLLED"_$CHAR(30)
+19 ;
XASTCON SET II=II+1
SET @DATA@(II)=$CHAR(31)
+1 QUIT
+2 ;
INJPLC(DATA,FAKE) ;EP - BJPN GET INJURY PLACE LIST
+1 ;
+2 NEW UID,II
+3 ;
+4 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+5 SET DATA=$NAME(^TMP("BJPNUTIL",UID))
+6 KILL @DATA
+7 IF $GET(DT)=""!($GET(U)="")
DO DT^DICRW
+8 ;
+9 SET II=0
+10 ; SAC 2009 2.2.3.17
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BJPNUTIL D UNWIND^%ZTER"
+11 ;
+12 ;Define header
+13 SET @DATA@(0)="T00005INJ_PLACE_CD^T00050INJURY_PLACE"_$CHAR(30)
+14 ;
+15 ;Hardset entries
+16 SET II=II+1
SET @DATA@(II)="A^HOME-INSIDE"_$CHAR(30)
+17 SET II=II+1
SET @DATA@(II)="B^HOME-OUTSIDE"_$CHAR(30)
+18 SET II=II+1
SET @DATA@(II)="C^FARM"_$CHAR(30)
+19 SET II=II+1
SET @DATA@(II)="D^SCHOOL"_$CHAR(30)
+20 SET II=II+1
SET @DATA@(II)="E^INDUSTRIAL PREMISES"_$CHAR(30)
+21 SET II=II+1
SET @DATA@(II)="F^RECREATIONAL AREA"_$CHAR(30)
+22 SET II=II+1
SET @DATA@(II)="G^STREET/HIGHWAY"_$CHAR(30)
+23 SET II=II+1
SET @DATA@(II)="H^PUBLIC BUILDING"_$CHAR(30)
+24 SET II=II+1
SET @DATA@(II)="I^RESIDENT INSTITUTION"_$CHAR(30)
+25 SET II=II+1
SET @DATA@(II)="J^HUNTING/FISHING"_$CHAR(30)
+26 SET II=II+1
SET @DATA@(II)="K^OTHER"_$CHAR(30)
+27 SET II=II+1
SET @DATA@(II)="L^UNKNOWN"_$CHAR(30)
+28 ;
XINJPLC SET II=II+1
SET @DATA@(II)=$CHAR(31)
+1 QUIT
+2 ;
DXCAUSE(DATA,FAKE) ;EP - BJPN GET DX CAUSE
+1 ;
+2 NEW UID,II,RET,ARR
+3 ;
+4 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+5 SET DATA=$NAME(^TMP("BJPNUTIL",UID))
+6 KILL @DATA
+7 IF $GET(DT)=""!($GET(U)="")
DO DT^DICRW
+8 ;
+9 SET II=0
+10 ; SAC 2009 2.2.3.17
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BJPNUTIL D UNWIND^%ZTER"
+11 ;
+12 ;Define header
+13 SET @DATA@(0)="T00010CODE^T00050DX_CAUSE"_$CHAR(30)
+14 ;
+15 DO GETSET^BGOUTL3(.RET,9000010.07,.07)
+16 ;
+17 SET ARR=""
FOR
SET ARR=$ORDER(RET(ARR))
IF ARR=""
QUIT
SET II=II+1
SET @DATA@(II)=$PIECE(RET(ARR),U)_U_$PIECE(RET(ARR),U,2)_$CHAR(30)
+18 ;
XDXCAUSE SET II=II+1
SET @DATA@(II)=$CHAR(31)
+1 QUIT
+2 ;
COMP(DFN,UID,VIEN,PRBIEN) ;EP - Call EHR API and format results into usable data
+1 ;
+2 NEW RET,TMP,T,BGO,LAT
+3 ;
+4 ;If no problem passed in get all
+5 IF $GET(PRBIEN)=""
DO GET^BGOPROB(.RET,DFN,"ASEORPI","A",99999,2)
+6 ;
+7 ;If problem passed in, get one
+8 IF +$GET(PRBIEN)
DO GETONE^BGOPROB1(.RET,+PRBIEN,2)
+9 ;
+10 ;Reset compile global - data to be used by this call and future RPC calls
+11 KILL ^TMP("BJPNIPL",UID)
+12 ;
+13 ;Populate info
+14 SET TMP=$NAME(^TMP("BJPNIPL",UID))
+15 SET (T,BGO)=""
FOR
SET BGO=$ORDER(@RET@(BGO))
IF BGO=""
QUIT
Begin DoDot:1
+16 NEW N
+17 SET N=$GET(@RET@(BGO))
+18 SET P=$GET(P)
+19 ;Problems
IF $PIECE(N,U)="P"
SET P=$PIECE(N,U,2)
IF P]""
SET B=BGO
SET @TMP@("P",P,B)=N
SET T="P"
QUIT
+20 ;Care Plans
IF $PIECE(N,U)="C"
SET P=$PIECE(N,U,3)
IF P]""
SET B=BGO
SET @TMP@("C",P,B,0)=N
SET T="C"
QUIT
+21 ;Goals
IF $PIECE(N,U)="G"
SET P=$PIECE(N,U,3)
IF P]""
SET B=BGO
SET @TMP@("G",P,B,0)=N
SET T="G"
QUIT
+22 ;Visit Instructions
IF $PIECE(N,U)="I"
SET P=$PIECE(N,U,3)
IF P]""
SET B=BGO
SET @TMP@("I",P,B,0)=N
SET T="I"
QUIT
+23 ;OB Note
IF $PIECE(N,U)="O"
SET P=$PIECE(N,U,3)
IF P]""
SET B=BGO
SET @TMP@("O",P,B,0)=N
SET T="O"
QUIT
+24 ;Treatment Regimen
IF $PIECE(N,U)="T"
SET P=$PIECE(N,U,4)
IF P]""
SET B=BGO
SET @TMP@("T",P,B,0)=N
SET T="T"
QUIT
+25 ;Education
IF $PIECE(N,U)="E"
IF P]""
SET B=BGO
SET @TMP@("E",P,B,0)=$$PTED^BJPNPUTL(N)
+26 ;Asthma
IF $PIECE(N,U)="A"
IF P]""
SET B=BGO
SET @TMP@("A",P,B,0)=N
+27 ;Qualifiers
IF $PIECE(N,U)="Q"
IF P]""
SET B=BGO
SET @TMP@("Q",P,B,0)=N
+28 ;
+29 ;C/G/I/O/T Text
+30 IF $EXTRACT(N,1)="~"
IF P]""
IF T]""
IF B]""
SET @TMP@(T,P,B,$ORDER(@TMP@(T,P,B,""),-1)+1)=N
End DoDot:1
+31 ;
+32 ;Get POVs
+33 IF $GET(VIEN)]""
Begin DoDot:1
+34 NEW FNDPS,PVLST,FINFO
+35 SET PVLST=""
+36 DO GET^BGOVPOV(.RET,VIEN)
+37 SET BGO=""
FOR
SET BGO=$ORDER(@RET@(BGO))
IF BGO=""
QUIT
Begin DoDot:2
+38 NEW N,P,PS,PENT,B,PVIEN,RETDATA
+39 SET N=$GET(@RET@(BGO))
+40 ;Problem
SET P=$PIECE(N,U,24)
+41 ;
+42 ;Quite if no problem
IF P=""
QUIT
+43 ;Quit if not in list
IF '$DATA(@TMP@("P",P))
QUIT
+44 ;Quit if no entry
SET B=$ORDER(@TMP@("P",P,""))
IF B=""
QUIT
+45 ;
+46 ;Primary/Secondary
SET PS=$PIECE(N,U,16)
+47 IF PS="PRIMARY"
SET FNDPS(P)="Y"
+48 ;POV IEN
SET PVIEN=$PIECE(N,U)
+49 IF PVIEN]""
SET PVLST=PVLST_$SELECT(PVLST]"":$CHAR(29),1:"")_PVIEN
+50 ;
+51 ;Look for episodicity and injury info
+52 IF $GET(FINFO(P))=""
Begin DoDot:3
+53 NEW EP,REV,INJCASS,PLC,INJDT,INJCEXT,INJCINT,AF,FRACT
+54 ;Episodicity
SET EP=$PIECE(N,U,6)
IF EP]""
SET FINFO(P)=1
+55 ;Injury Revisit
SET REV=$PIECE(N,U,11)
IF REV]""
SET FINFO(P)=1
+56 ;Inj Association
SET INJCASS=$PIECE(N,U,12)
IF INJCASS]""
SET FINFO(P)=1
+57 ;Inj Place
SET PLC=$PIECE($PIECE(N,U,15),"~")
IF PLC]""
SET FINFO(P)=1
+58 ;Injury Date
SET INJDT=$PIECE(N,U,13)
IF INJDT]""
SET FINFO(P)=1
+59 ;Ext Inj Cause
SET INJCEXT=$PIECE(N,U,14)
IF INJCEXT]""
SET FINFO(P)=1
+60 ;Int Inj Cause
SET INJCINT=$PIECE(N,U,25)
IF INJCINT]""
SET FINFO(P)=1
+61 ;BJPN*2.0*6;Include abnormal findings
+62 SET AF=$PIECE($PIECE(N,U,28),";")
+63 IF AF]""
SET AF=$ORDER(^BSTS(9002318.6,"C","AF",AF,""))
+64 ;Abnormal Findings
IF AF]""
SET FINFO(P)=1
+65 ;BJPN*2.0*9;Include Fracture
+66 SET FRACT=$PIECE(N,U,30)
+67 SET FINFO(P,"FRACT")=FRACT
+68 SET FINFO(P,"AF")=AF
+69 SET FINFO(P,"EP")=EP
+70 SET FINFO(P,"REV")=REV
+71 SET FINFO(P,"INJCASS")=INJCASS
+72 SET FINFO(P,"PLC")=PLC
+73 SET FINFO(P,"INJDT")=INJDT
+74 SET FINFO(P,"INJCEXT")=INJCEXT
+75 SET FINFO(P,"INJCINT")=INJCINT
End DoDot:3
+76 ;
+77 ;BJPN*2.0*9;Added fracture in 40
+78 ;Set the Primary/Secondary,POV IEN, Episodicity in the problem entry
+79 SET RETDATA=$GET(FNDPS(P))_U_PVLST_U_$GET(FINFO(P,"EP"))_U_$GET(FINFO(P,"REV"))_U_$GET(FINFO(P,"PLC"))
+80 SET RETDATA=RETDATA_U_$GET(FINFO(P,"INJDT"))_U_$GET(FINFO(P,"INJCEXT"))_U_$GET(FINFO(P,"INJCINT"))_U_$GET(FINFO(P,"INJCASS"))_U_$GET(FINFO(P,"AF"))_U_$GET(FINFO(P,"FRACT"))
+81 SET $PIECE(@TMP@("P",P,B),U,30,40)=RETDATA
End DoDot:2
End DoDot:1
+82 ;
+83 QUIT
+84 ;
INJURY(DATA,CODE,SNOMED) ;EP - BJPN INJURY CHECK
+1 ;
+2 NEW UID,II,RET
+3 ;
+4 SET UID=$SELECT($GET(ZTSK):"Z"_ZTSK,1:$JOB)
+5 SET DATA=$NAME(^TMP("BJPNUTIL",UID))
+6 KILL @DATA
+7 IF $GET(DT)=""!($GET(U)="")
DO DT^DICRW
+8 ;
+9 SET II=0
+10 ; SAC 2009 2.2.3.17
NEW $ESTACK,$ETRAP
SET $ETRAP="D ERR^BJPNUTIL D UNWIND^%ZTER"
+11 ;
+12 ;Define header
+13 SET @DATA@(0)="I00001RESULT"_$CHAR(30)
+14 ;
+15 IF $GET(CODE)=""
SET BMXSEC="Missing ICD code value"
GOTO XINJURY
+16 IF $GET(SNOMED)=""
SET BMXSEC="Missing SNOMED code"
GOTO XINJURY
+17 ;
+18 ;Call MSC to perform check
+19 DO CHKASM^BGOASLK(.RET,CODE,SNOMED)
+20 SET II=II+1
SET @DATA@(II)=+$GET(RET)_$CHAR(30)
+21 ;
XINJURY 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 QUIT
