AUPNVUTL ; IHS/CMI/LAB - AUPN UTILITIES ; 25 Feb 2016 12:47 PM
;;2.0;IHS PCC SUITE;**2,10,11,15,16,17,22**;MAY 14, 2009;Build 6
SNOMED(N) ;PEP - called from various dds provider narrative
;TRANSFORM TO ADD DESCRIPTIVE TEXT FOR SNOMED CODE IF THERE IS A "|" PIECE
I $G(N)="" Q N
S N=$P($G(^AUTNPOV(N,0)),U,1)
I N'["|" Q N ; no vertical equals no snomed desc id
I N["| " Q N ;prenatal v1.0
I $T(DESC^BSTSAPI)="" Q N ;no snomed stuff installed
NEW SDI,SDIT,LAT
S (SDI,SDIT)=$P(N,"|",2) ;snomed descriptive id is in piece 2
S LAT=$P(N,"|",3) ;laterality text is in piece 3
I SDI?.AN S SDIT=$P($$DESC^BSTSAPI(SDI_"^^1"),U,2)
I SDIT="",SDI]"" S SDIT=SDI
I SDIT="" Q "*"_$P(N,"|",1) ;not snomed text?? somebody stored a bad descriptive id return "* | " per Susan
Q SDIT_$S(LAT]"":", "_LAT,1:"")_" | "_$P(N,"|",1)
PNPROB(N) ;PEP - called from various dds provider narrative
;TRANSFORM TO ADD DESCRIPTIVE TEXT FOR SNOMED CODE IF THERE IS A "|" PIECE
;N must be a valid IEN in AUTNPOV (provider narrative)
I $G(N)="" Q N
S N=$P($G(^AUTNPOV(N,0)),U,1)
I N'["|" Q "*"_N ; no vertical equals no snomed desc id
I N["| " Q N ;prenatal v1.0
I $T(DESC^BSTSAPI)="" Q "*"_N ;no snomed stuff installed
NEW SDI,SDIT,LAT
S (SDI,SDIT)=$P(N,"|",2) ;snomed descriptive id is in piece 2
S LAT=$P(N,"|",3) ;laterality text is in piece 3
I SDI?.AN S SDIT=$P($$DESC^BSTSAPI(SDI_"^^1"),U,2)
I SDIT="" S SDIT=SDI
I SDIT="" Q "*"_$P(N,"|",1) ;not snomed text?? somebody stored a bad descriptive id return "* | " per Susan
Q SDIT_$S(LAT]"":", "_LAT,1:"")_" | "_$P(N,"|",1)
EXFIND(%) ;PEP - RETURN EXAM FINDING TEXT BASED ON SNOMED CODE
;NOTE: only 2 SNOMEDs are supported at this time, this will need to be updated if others are ever added.
I %=162656002 Q "without abnormal findings"
I %=71994000 Q "with abnormal findings"
Q %
AQ(%) ;PEP RETURN HUMAN READABLE LATERALITY ATTRIBUTE/QUALIFIER VALUE
NEW A,Q,V,A1
I $G(%)="" Q ""
S A=$P(%,"|")
I A="" S V="" G AQQ
;S V=$$CONCPT(A)
S V=$$CVPARM^BSTSMAP1("LAT",A)
I V="" S V=A ;if no text just use the code
AQQ ;
S V=V_"|"
S Q=$P(%,"|",2)
I Q="" Q V
;S A1=$$CONCPT(Q)
S A1=$$CVPARM^BSTSMAP1("LAT",Q)
I A1="" S A1=Q
Q V_A1
EDNAME(I) ;PEP - RETURN EDUCATION TOPIC TEXT
;if the topic contains a snomed display preferred term and then subtopic
NEW N
I $G(I)="" Q I
S N=$P($G(^AUTTEDT(I,0)),U,1)
I $P($G(^AUTTEDT(I,0)),U,12)="" Q N
I $T(CONC^BSTSAPI)="" Q N ;no snomed stuff installed
NEW SDI,SDIT
S SDI=$P(N,"-",1) ;snomed descriptive id is in piece 2
S SDIT=$$CONCPT(SDI)
I SDIT="" Q N ;not snomed text?? somebody stored a bad descriptive id return "* | " per Susan
Q SDIT_"-"_$P(N,"-",2)
FSOT(X) ;PEP - FINDING SITE OUTPUT TX/COMPUTED FIELD
;get each | piece, then each ":" piece and get perferred term
I $T(CONC^BSTSAPI)="" Q ""
I $G(X)="" Q ""
NEW A,B,V,D,E
S V=""
F A=1:1 S B=$P(X,"|",A) Q:B="" D
.;S D=$P(B,":",1)
.S E=$P(B,":",2)
.I V]"" S V=V_", "
.; V=V_$$CONCPT(D)_":"_$$CONCPT(E)
.S V=V_$$CONCPT(E)
Q V
TESTFS ;
;
S X="272741003:7771000|363698007:56459004"
W $$FSOT(X)
Q
CONC(X) ;EP 22
;CALLED FROM VARIOUS PCC ROUTINES TO GET CONCEPT ID IF BSTS IS INSTALLED
I $T(CONC^BSTSAPI)="" Q ""
I $G(X)="" Q ""
Q $$CONC^AUPNSICD(X_"^^^1")
CONCPT(X) ;PEP - GET CONCEPT PREFERRED TERM
;CALLED FROM VARIOUS PCC ROUTINES TO GET CONCEPT ID PREFERRED TERM IF BSTS IS INSTALLED
I $T(CONC^BSTSAPI)="" Q ""
I $G(X)="" Q ""
NEW D,B,E,V,A,B
Q $P($$CONC^BSTSAPI(X_"^^^1"),U,4)
DESCPT(X) ;PEP - GET DESC ID
I $T(DESC^BSTSAPI)="" Q ""
I $G(X)="" Q ""
I $G(X)'?.AN Q X
Q $P($$DESC^BSTSAPI(X_"^^1"),U,2)
LOINCT(X) ;EP
;put api in here when get it from apelon group
Q ""
LOINCPT(X) ;EP
;put api in here when get it from apelon group
Q ""
ICD(X,Y,Z) ;PEP - CHECK FOR ICD10
;I $T(ICD^ATXAPI)]"" Q $$ICD^ATXAPI(X,Y,Z)
Q $$ICD^ATXCHK(X,Y,Z)
;
ICDDX(C,D,I) ;PEP - CHECK FOR ICD10
I $G(I)="" S I="I"
I $T(ICDDX^ICDEX)]"" Q $$ICDDX^ICDEX(C,$G(D),,I)
Q $$ICDDX^ICDCODE(C,$G(D))
;
ICDOP(C,D,I) ;PEP - CHECK FOR ICD10
I $G(I)="" S I="E"
I $T(ICDOP^ICDEX)]"" Q $$ICDOP^ICDEX(C,$G(D),,I)
Q $$ICDOP^ICDCODE(C,$G(D))
;
VSTD(C,D) ;EP - CHECK FOR ICD10
I $T(VSTD^ICDEX)]"" Q $$VSTD^ICDEX(C,$G(D))
Q $$VSTD^ICDCODE(C,$G(D))
;
VSTP(C,D) ;EP - CHECK FOR ICD10
I $T(VSTP^ICDEX)]"" Q $$VSTP^ICDEX(C,$G(D))
Q $$VSTP^ICDCODE(C,$G(D))
;
ICDD(C,A,D) ;EP - CHECK FOR ICD10
I $T(ICDD^ICDEX)]"" Q $$ICDD^ICDEX(C,A,$G(D))
Q $$ICDD^ICDCODE(C,A,$G(D))
CONFSN(C) ;EP - FSN
;CALLED FROM VARIOUS PCC ROUTINES TO GET CONCEPT ID FSN IF BSTS IS INSTALLED
I $T(CONC^BSTSAPI)="" Q ""
I $G(X)="" Q ""
Q $P($$CONC^BSTSAPI(X_"^^^1"),U,2)
MC(X) ;EP - called from cross ref
I $G(X)="" Q ""
NEW A,B,C
S A=$O(^AUTTREFR("B",X,0))
I 'A Q ""
Q $P($G(^AUTTREFR(A,0)),U,4)
M07(X) ;EP - map .07 to 1.01
I $G(X)="" Q ""
NEW A
S A=$O(^AUTTREFR("AM",X,0))
I 'A Q ""
Q $P(^AUTTREFR(A,0),U,1)
;
IMP(%) ;EP
Q $$IMP^ICDEX(%)
REFR(%) ;PEP - REFUSAL REASON TEXT FORM
I '$G(%) Q ""
I '$D(^AUPNPREF(%,0)) Q ""
NEW A,B,C
S A=$$VAL^XBDIQ1(9000022,%,1.01)
I A]"" S A=$$CONCPT(A)
I A]"" Q A
Q $$VAL^XBDIQ1(9000022,%,.07)
IN6404 ;EP - input transform on .04 V Delivery
NEW LIST,AUPNX
K LIST
S AUPNX=$$SUBLST^BSTSAPI("LIST","EHR LABOR ESTABLISHED")
;BUILD INDEX
S AUPNX=0 F S AUPNX=$O(LIST(AUPNX)) Q:AUPNX'=+AUPNX S LIST("B",$P(LIST(AUPNX),U,1))=""
I $O(LIST(0)),'$D(LIST("B",X)) K X Q
Q
IN6407 ;EP - input transform on .04 V Delivery
NEW LIST,AUPNX
K LIST
S AUPNX=$$SUBLST^BSTSAPI("LIST","EHR LABOR INDUCTION TYPE")
;BUILD INDEX
S AUPNX=0 F S AUPNX=$O(LIST(AUPNX)) Q:AUPNX'=+AUPNX S LIST("B",$P(LIST(AUPNX),U,1))=""
I $O(LIST(0)),'$D(LIST("B",X)) K X Q
Q
AUPNVUTL ; IHS/CMI/LAB - AUPN UTILITIES ; 25 Feb 2016 12:47 PM
+1 ;;2.0;IHS PCC SUITE;**2,10,11,15,16,17,22**;MAY 14, 2009;Build 6
SNOMED(N) ;PEP - called from various dds provider narrative
+1 ;TRANSFORM TO ADD DESCRIPTIVE TEXT FOR SNOMED CODE IF THERE IS A "|" PIECE
+2 IF $GET(N)=""
QUIT N
+3 SET N=$PIECE($GET(^AUTNPOV(N,0)),U,1)
+4 ; no vertical equals no snomed desc id
IF N'["|"
QUIT N
+5 ;prenatal v1.0
IF N["| "
QUIT N
+6 ;no snomed stuff installed
IF $TEXT(DESC^BSTSAPI)=""
QUIT N
+7 NEW SDI,SDIT,LAT
+8 ;snomed descriptive id is in piece 2
SET (SDI,SDIT)=$PIECE(N,"|",2)
+9 ;laterality text is in piece 3
SET LAT=$PIECE(N,"|",3)
+10 IF SDI?.AN
SET SDIT=$PIECE($$DESC^BSTSAPI(SDI_"^^1"),U,2)
+11 IF SDIT=""
IF SDI]""
SET SDIT=SDI
+12 ;not snomed text?? somebody stored a bad descriptive id return "* | " per Susan
IF SDIT=""
QUIT "*"_$PIECE(N,"|",1)
+13 QUIT SDIT_$SELECT(LAT]"":", "_LAT,1:"")_" | "_$PIECE(N,"|",1)
PNPROB(N) ;PEP - called from various dds provider narrative
+1 ;TRANSFORM TO ADD DESCRIPTIVE TEXT FOR SNOMED CODE IF THERE IS A "|" PIECE
+2 ;N must be a valid IEN in AUTNPOV (provider narrative)
+3 IF $GET(N)=""
QUIT N
+4 SET N=$PIECE($GET(^AUTNPOV(N,0)),U,1)
+5 ; no vertical equals no snomed desc id
IF N'["|"
QUIT "*"_N
+6 ;prenatal v1.0
IF N["| "
QUIT N
+7 ;no snomed stuff installed
IF $TEXT(DESC^BSTSAPI)=""
QUIT "*"_N
+8 NEW SDI,SDIT,LAT
+9 ;snomed descriptive id is in piece 2
SET (SDI,SDIT)=$PIECE(N,"|",2)
+10 ;laterality text is in piece 3
SET LAT=$PIECE(N,"|",3)
+11 IF SDI?.AN
SET SDIT=$PIECE($$DESC^BSTSAPI(SDI_"^^1"),U,2)
+12 IF SDIT=""
SET SDIT=SDI
+13 ;not snomed text?? somebody stored a bad descriptive id return "* | " per Susan
IF SDIT=""
QUIT "*"_$PIECE(N,"|",1)
+14 QUIT SDIT_$SELECT(LAT]"":", "_LAT,1:"")_" | "_$PIECE(N,"|",1)
EXFIND(%) ;PEP - RETURN EXAM FINDING TEXT BASED ON SNOMED CODE
+1 ;NOTE: only 2 SNOMEDs are supported at this time, this will need to be updated if others are ever added.
+2 IF %=162656002
QUIT "without abnormal findings"
+3 IF %=71994000
QUIT "with abnormal findings"
+4 QUIT %
AQ(%) ;PEP RETURN HUMAN READABLE LATERALITY ATTRIBUTE/QUALIFIER VALUE
+1 NEW A,Q,V,A1
+2 IF $GET(%)=""
QUIT ""
+3 SET A=$PIECE(%,"|")
+4 IF A=""
SET V=""
GOTO AQQ
+5 ;S V=$$CONCPT(A)
+6 SET V=$$CVPARM^BSTSMAP1("LAT",A)
+7 ;if no text just use the code
IF V=""
SET V=A
AQQ ;
+1 SET V=V_"|"
+2 SET Q=$PIECE(%,"|",2)
+3 IF Q=""
QUIT V
+4 ;S A1=$$CONCPT(Q)
+5 SET A1=$$CVPARM^BSTSMAP1("LAT",Q)
+6 IF A1=""
SET A1=Q
+7 QUIT V_A1
EDNAME(I) ;PEP - RETURN EDUCATION TOPIC TEXT
+1 ;if the topic contains a snomed display preferred term and then subtopic
+2 NEW N
+3 IF $GET(I)=""
QUIT I
+4 SET N=$PIECE($GET(^AUTTEDT(I,0)),U,1)
+5 IF $PIECE($GET(^AUTTEDT(I,0)),U,12)=""
QUIT N
+6 ;no snomed stuff installed
IF $TEXT(CONC^BSTSAPI)=""
QUIT N
+7 NEW SDI,SDIT
+8 ;snomed descriptive id is in piece 2
SET SDI=$PIECE(N,"-",1)
+9 SET SDIT=$$CONCPT(SDI)
+10 ;not snomed text?? somebody stored a bad descriptive id return "* | " per Susan
IF SDIT=""
QUIT N
+11 QUIT SDIT_"-"_$PIECE(N,"-",2)
FSOT(X) ;PEP - FINDING SITE OUTPUT TX/COMPUTED FIELD
+1 ;get each | piece, then each ":" piece and get perferred term
+2 IF $TEXT(CONC^BSTSAPI)=""
QUIT ""
+3 IF $GET(X)=""
QUIT ""
+4 NEW A,B,V,D,E
+5 SET V=""
+6 FOR A=1:1
SET B=$PIECE(X,"|",A)
IF B=""
QUIT
Begin DoDot:1
+7 ;S D=$P(B,":",1)
+8 SET E=$PIECE(B,":",2)
+9 IF V]""
SET V=V_", "
+10 ; V=V_$$CONCPT(D)_":"_$$CONCPT(E)
+11 SET V=V_$$CONCPT(E)
End DoDot:1
+12 QUIT V
TESTFS ;
+1 ;
+2 SET X="272741003:7771000|363698007:56459004"
+3 WRITE $$FSOT(X)
+4 QUIT
CONC(X) ;EP 22
+1 ;CALLED FROM VARIOUS PCC ROUTINES TO GET CONCEPT ID IF BSTS IS INSTALLED
+2 IF $TEXT(CONC^BSTSAPI)=""
QUIT ""
+3 IF $GET(X)=""
QUIT ""
+4 QUIT $$CONC^AUPNSICD(X_"^^^1")
CONCPT(X) ;PEP - GET CONCEPT PREFERRED TERM
+1 ;CALLED FROM VARIOUS PCC ROUTINES TO GET CONCEPT ID PREFERRED TERM IF BSTS IS INSTALLED
+2 IF $TEXT(CONC^BSTSAPI)=""
QUIT ""
+3 IF $GET(X)=""
QUIT ""
+4 NEW D,B,E,V,A,B
+5 QUIT $PIECE($$CONC^BSTSAPI(X_"^^^1"),U,4)
DESCPT(X) ;PEP - GET DESC ID
+1 IF $TEXT(DESC^BSTSAPI)=""
QUIT ""
+2 IF $GET(X)=""
QUIT ""
+3 IF $GET(X)'?.AN
QUIT X
+4 QUIT $PIECE($$DESC^BSTSAPI(X_"^^1"),U,2)
LOINCT(X) ;EP
+1 ;put api in here when get it from apelon group
+2 QUIT ""
LOINCPT(X) ;EP
+1 ;put api in here when get it from apelon group
+2 QUIT ""
ICD(X,Y,Z) ;PEP - CHECK FOR ICD10
+1 ;I $T(ICD^ATXAPI)]"" Q $$ICD^ATXAPI(X,Y,Z)
+2 QUIT $$ICD^ATXCHK(X,Y,Z)
+3 ;
ICDDX(C,D,I) ;PEP - CHECK FOR ICD10
+1 IF $GET(I)=""
SET I="I"
+2 IF $TEXT(ICDDX^ICDEX)]""
QUIT $$ICDDX^ICDEX(C,$GET(D),,I)
+3 QUIT $$ICDDX^ICDCODE(C,$GET(D))
+4 ;
ICDOP(C,D,I) ;PEP - CHECK FOR ICD10
+1 IF $GET(I)=""
SET I="E"
+2 IF $TEXT(ICDOP^ICDEX)]""
QUIT $$ICDOP^ICDEX(C,$GET(D),,I)
+3 QUIT $$ICDOP^ICDCODE(C,$GET(D))
+4 ;
VSTD(C,D) ;EP - CHECK FOR ICD10
+1 IF $TEXT(VSTD^ICDEX)]""
QUIT $$VSTD^ICDEX(C,$GET(D))
+2 QUIT $$VSTD^ICDCODE(C,$GET(D))
+3 ;
VSTP(C,D) ;EP - CHECK FOR ICD10
+1 IF $TEXT(VSTP^ICDEX)]""
QUIT $$VSTP^ICDEX(C,$GET(D))
+2 QUIT $$VSTP^ICDCODE(C,$GET(D))
+3 ;
ICDD(C,A,D) ;EP - CHECK FOR ICD10
+1 IF $TEXT(ICDD^ICDEX)]""
QUIT $$ICDD^ICDEX(C,A,$GET(D))
+2 QUIT $$ICDD^ICDCODE(C,A,$GET(D))
CONFSN(C) ;EP - FSN
+1 ;CALLED FROM VARIOUS PCC ROUTINES TO GET CONCEPT ID FSN IF BSTS IS INSTALLED
+2 IF $TEXT(CONC^BSTSAPI)=""
QUIT ""
+3 IF $GET(X)=""
QUIT ""
+4 QUIT $PIECE($$CONC^BSTSAPI(X_"^^^1"),U,2)
MC(X) ;EP - called from cross ref
+1 IF $GET(X)=""
QUIT ""
+2 NEW A,B,C
+3 SET A=$ORDER(^AUTTREFR("B",X,0))
+4 IF 'A
QUIT ""
+5 QUIT $PIECE($GET(^AUTTREFR(A,0)),U,4)
M07(X) ;EP - map .07 to 1.01
+1 IF $GET(X)=""
QUIT ""
+2 NEW A
+3 SET A=$ORDER(^AUTTREFR("AM",X,0))
+4 IF 'A
QUIT ""
+5 QUIT $PIECE(^AUTTREFR(A,0),U,1)
+6 ;
IMP(%) ;EP
+1 QUIT $$IMP^ICDEX(%)
REFR(%) ;PEP - REFUSAL REASON TEXT FORM
+1 IF '$GET(%)
QUIT ""
+2 IF '$DATA(^AUPNPREF(%,0))
QUIT ""
+3 NEW A,B,C
+4 SET A=$$VAL^XBDIQ1(9000022,%,1.01)
+5 IF A]""
SET A=$$CONCPT(A)
+6 IF A]""
QUIT A
+7 QUIT $$VAL^XBDIQ1(9000022,%,.07)
IN6404 ;EP - input transform on .04 V Delivery
+1 NEW LIST,AUPNX
+2 KILL LIST
+3 SET AUPNX=$$SUBLST^BSTSAPI("LIST","EHR LABOR ESTABLISHED")
+4 ;BUILD INDEX
+5 SET AUPNX=0
FOR
SET AUPNX=$ORDER(LIST(AUPNX))
IF AUPNX'=+AUPNX
QUIT
SET LIST("B",$PIECE(LIST(AUPNX),U,1))=""
+6 IF $ORDER(LIST(0))
IF '$DATA(LIST("B",X))
KILL X
QUIT
+7 QUIT
IN6407 ;EP - input transform on .04 V Delivery
+1 NEW LIST,AUPNX
+2 KILL LIST
+3 SET AUPNX=$$SUBLST^BSTSAPI("LIST","EHR LABOR INDUCTION TYPE")
+4 ;BUILD INDEX
+5 SET AUPNX=0
FOR
SET AUPNX=$ORDER(LIST(AUPNX))
IF AUPNX'=+AUPNX
QUIT
SET LIST("B",$PIECE(LIST(AUPNX),U,1))=""
+6 IF $ORDER(LIST(0))
IF '$DATA(LIST("B",X))
KILL X
QUIT
+7 QUIT
