AUPNVUTL.m

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