BMCADD3.m

BMCADD3 ;IHS/ITSC/FCJ - ADD SNOMED CODES TO REFERRAL;        [ 09/27/2006  1:31 PM ]

 ;;4.0;REFERRED CARE INFO SYSTEM;**8,9,12**;JAN 09, 2006;Build 101

 ;

 ; 4.0*8 NEW ROUTINE

 ; Routine will update the RCIS SNOMED field- V Referral file

 ;

START ;

 K ^XTMP("BMCSNO",$J)

 NEW DDS,DIR

 D:'$D(BMCPARM) PARMCHK^BMC

 W @IOF

 ;BMC*4.0*9 TST FOR SNOMED CD IN REF OR VREF

 ;I (BMCMODE="M")!(BMCMODE="E") D  Q:('BMCVREF)!(BMCRSTAT'="A")

 I (BMCMODE="M")!(BMCMODE="E") D  Q:('BMCSCOD)!(BMCRSTAT'="A")

 .;I 'BMCVREF W !!?5,"This field is not editable because original referral does not have",!,"a SNOMED code." H 3 Q  ;BMC*3.1*9

 .I 'BMCSCOD W !!?5,"This field is not editable because original referral does not have",!,"a SNOMED code." H 3 Q   ;BMC*3.1*9

 .I BMCRSTAT'="A" W !!,"This field is not editable because referral status is not ACTIVE." H 3 Q

 D MAIN

 D EXIT

 Q

 ;

MAIN ;

 S BMCQ=0

 I $G(BMCSCOD)>0 D  Q:'+Y

 .W !,"SNOMED Clinical Term selected: ",BMCSCOD,"  ",BMCSTRM,!

 .I (BMCMODE="M")!(BMCMODE="E") W !,"Editing the SNOMED Code will automatically update the Referral.",!

 .S DIR(0)="Y",DIR("A")="Edit the SNOMED Referral Clinical Term",DIR("B")="N"

 .D ^DIR

 .K DIR

 S (BMCSNO,BMCSTRM,BMCSCOD)=""

 ;

SNO ;REQUEST SNOMED

 W !

 S DIR(0)="F",DIR("A")="Enter the Referral Snomed Term"

 S:BMCMODE="R" DIR(0)="FO"

 S DIR("?")="Enter a Snomed code or partial name, example 'PEDIA' will list all PEDIACTRIC Referral Snomed codes, enter a '??' for a list of codes"

 S DIR("??")="^D SNOLST^BMCADD3"

 D ^DIR

 I BMCMODE="R",$D(DUOUT) Q

 I BMCMODE="R",$D(DIRUT) S BMCSCOD="@" D VREF^BMCAERR Q

 I $D(DUOUT),$G(BMCRREF) Q

 I $D(DUOUT) W !!,"Snomed Clinical Term required." G SNO

 K ^XTMP("BMCSNO",$J)

 S SNOLST=$NA(^XTMP("BMCSNO",$J)),BMCSNO=X

 ;S OUT=SNOLST,IN=BMCSNO_"^F^^EHR REFERRAL TYPE^^^P^1^^^"  ;5/22/17 BMC*3.1*12 IHS/OIT/FCJ USE LOCAL SYS FOR LOOKUP

 S OUT=SNOLST,IN=BMCSNO_"^F^^EHR REFERRAL TYPE^^^P^1^^^1"  ;5/22/17 BMC*3.1*12

 S X=$$SEARCH^BSTSAPI(OUT,IN)

 I +X=0 W !,"INVALID RESPONSE" G SNO ; ERROR

 ;DISPLAY

 K DIR

 S (CT,L)=0

 F  S L=$O(^XTMP("BMCSNO",$J,L)) Q:L'?1N.N  S CT=L

 ;

 F L=1:1:CT D  Q:BMCQ  G:$D(DUOUT) SNO

 .;W !?4,L,".",?8,^XTMP("BMCSNO",$J,L,"PRB","DSC"),?20,^XTMP("BMCSNO",$J,L,"PRB","TRM")

 .W !?4,L,".",?8,^XTMP("BMCSNO",$J,L,"CON"),?20,^XTMP("BMCSNO",$J,L,"FSN","TRM")

 .I L=CT D  I 'BMCQ W !!,"Snomed Clinical Term required." G SNO

 ..W !

 ..S DIR(0)="L^1:"_L,DIR("A")="Enter the corresponding number" D ^DIR

 ..I +X>0 S BMCQ=1,BMCSNO=X

 .I L#20=0 D SEL

 ;I BMCSNO>0 S BMCSCOD=^XTMP("BMCSNO",$J,BMCSNO,"PRB","DSC"),BMCSTRM=^XTMP("BMCSNO",$J,BMCSNO,"PRB","TRM")

 I BMCSNO>0 S BMCSCOD=^XTMP("BMCSNO",$J,BMCSNO,"CON"),BMCSTRM=^XTMP("BMCSNO",$J,BMCSNO,"FSN","TRM")

 K DIR

 Q

SEL ;SELECT

 W !

 S DIR(0)="LO^1:"_L

 S DIR("A")="Enter the corresponding number or return to continue"

 D ^DIR

 I $D(DUOUT) W !!,"SNOMED Clinical Term required."

 I X>0 S BMCQ=1,BMCSNO=+X

 W !

 K DIR

 Q

 ;

SNOLST ;LIST THE SNOMED CODES

 NEW DIR

 S SNOLST=$NA(^XTMP("BMCSNO",$J))

 ;S X=$$SUBLST^BSTSAPI(SNOLST,"EHR REFERRAL TYPE"),L=0    ;5/22/17 BMC*3.1*12 IHS/OIT/FCJ USE LOCAL SYS FOR LOOKUP

 S X=$$SUBLST^BSTSAPI(SNOLST,"EHR REFERRAL TYPE^^1"),L=0  ;5/22/17 BMC*3.1*12

 ;5/22/17 BMC*4.0*12 IHS/OIT/FCJ ALPHA LIST OF CODES INSTEAD OF NUMERIC

 F  S L=$O(^XTMP("BMCSNO",$J,L)) Q:L'?1N.N  S ^XTMP("BMCSNO",$J,"B",$P(^XTMP("BMCSNO",$J,L),U,3),L)=""

 S L=0,L2=0 F  S L=$O(^XTMP("BMCSNO",$J,"B",L)) Q:L=""  D  Q:$D(DUOUT)

 .S L1=0 F  S L1=$O(^XTMP("BMCSNO",$J,"B",L,L1)) Q:L1'?1N.N  D  Q:$D(DUOUT)

 ..W !?5,$P(^XTMP("BMCSNO",$J,L1),U),?15,$P(^XTMP("BMCSNO",$J,L1),U,3) S L2=L2+1

 ..;W !?5,$P(^XTMP("BMCSNO",$J,L),U),?15,$P(^XTMP("BMCSNO",$J,L),U,3)

 ..I L2#20=0 W ! S DIR(0)="E",DIR("A")="Press return to continue or '^' to exit list" D ^DIR W @IOF

 ;5/22/17 BMC*4.0*12 IHS/OIT/FCJ END MODS

 Q

 ;

EXIT ;EXIT PROGRAM

 K X,L,L1,L2,^XTMP("BMCSNO",$J)

 S BMCQ=0

 I BMCMODE="R",'$G(BMCSCOD) S BMCSCOD=$P($G(^BMCRTNRF(BMCRREF,13)),U,3) S:BMCSCOD BMCSTRM=$P($$CONC^BSTSAPI(BMCSCOD_"^^^1"),U,2)

 Q

GETSNO ;EP FR BMCMOD AND BMCMODS;GET SNOMED TERM DESCRIPTION

 S BMCSCOD="",BMCSTRM="",BMCVREF=""

 S BMCVREF=$P($G(^BMCREF(BMCRIEN,13)),U,3)

 ;BMC*4.0*9 TEST FOR PCC V REF FIRST THEN REF FILE

 ;Q:'BMCVREF

 I 'BMCVREF D  Q

 .S BMCSCOD=$P($G(^BMCREF(BMCRIEN,22,1,0)),U)

 .S BMCSTRM=$P($$CONC^BSTSAPI(BMCSCOD_"^^^1"),U,2)

 S BMCSCOD=$P(^AUPNVREF(BMCVREF,0),U)

 S BMCSTRM=$P($$CONC^BSTSAPI(BMCSCOD_"^^^1"),U,2)

 ;S BMCSTRM=$P($$DESC^BSTSAPI(BMCSCOD),U,2)

 Q

BMCADD3   ;IHS/ITSC/FCJ - ADD SNOMED CODES TO REFERRAL;        [ 09/27/2006  1:31 PM ]

 +1       ;;4.0;REFERRED CARE INFO SYSTEM;**8,9,12**;JAN 09, 2006;Build 101

 +2       ;

 +3       ; 4.0*8 NEW ROUTINE

 +4       ; Routine will update the RCIS SNOMED field- V Referral file

 +5       ;

START     ;

 +1        KILL ^XTMP("BMCSNO",$JOB)

 +2        NEW DDS,DIR

 +3        IF '$DATA(BMCPARM)

               DO PARMCHK^BMC

 +4        WRITE @IOF

 +5       ;BMC*4.0*9 TST FOR SNOMED CD IN REF OR VREF

 +6       ;I (BMCMODE="M")!(BMCMODE="E") D  Q:('BMCVREF)!(BMCRSTAT'="A")

 +7        IF (BMCMODE="M")!(BMCMODE="E")

               Begin DoDot:1

 +8       ;I 'BMCVREF W !!?5,"This field is not editable because original referral does not have",!,"a SNOMED code." H 3 Q  ;BMC*3.1*9

 +9       ;BMC*3.1*9

                   IF 'BMCSCOD

                       WRITE !!?5,"This field is not editable because original referral does not have",!,"a SNOMED code."

                       HANG 3

                       QUIT 

 +10               IF BMCRSTAT'="A"

                       WRITE !!,"This field is not editable because referral status is not ACTIVE."

                       HANG 3

                       QUIT 

               End DoDot:1

               IF ('BMCSCOD)!(BMCRSTAT'="A")

                   QUIT 

 +11       DO MAIN

 +12       DO EXIT

 +13       QUIT 

 +14      ;

MAIN      ;

 +1        SET BMCQ=0

 +2        IF $GET(BMCSCOD)>0

               Begin DoDot:1

 +3                WRITE !,"SNOMED Clinical Term selected: ",BMCSCOD,"  ",BMCSTRM,!

 +4                IF (BMCMODE="M")!(BMCMODE="E")

                       WRITE !,"Editing the SNOMED Code will automatically update the Referral.",!

 +5                SET DIR(0)="Y"

                   SET DIR("A")="Edit the SNOMED Referral Clinical Term"

                   SET DIR("B")="N"

 +6                DO ^DIR

 +7                KILL DIR

               End DoDot:1

               IF '+Y

                   QUIT 

 +8        SET (BMCSNO,BMCSTRM,BMCSCOD)=""

 +9       ;

SNO       ;REQUEST SNOMED

 +1        WRITE !

 +2        SET DIR(0)="F"

           SET DIR("A")="Enter the Referral Snomed Term"

 +3        IF BMCMODE="R"

               SET DIR(0)="FO"

 +4        SET DIR("?")="Enter a Snomed code or partial name, example 'PEDIA' will list all PEDIACTRIC Referral Snomed codes, enter a '??' for a list of codes"

 +5        SET DIR("??")="^D SNOLST^BMCADD3"

 +6        DO ^DIR

 +7        IF BMCMODE="R"

               IF $DATA(DUOUT)

                   QUIT 

 +8        IF BMCMODE="R"

               IF $DATA(DIRUT)

                   SET BMCSCOD="@"

                   DO VREF^BMCAERR

                   QUIT 

 +9        IF $DATA(DUOUT)

               IF $GET(BMCRREF)

                   QUIT 

 +10       IF $DATA(DUOUT)

               WRITE !!,"Snomed Clinical Term required."

               GOTO SNO

 +11       KILL ^XTMP("BMCSNO",$JOB)

 +12       SET SNOLST=$NAME(^XTMP("BMCSNO",$JOB))

           SET BMCSNO=X

 +13      ;S OUT=SNOLST,IN=BMCSNO_"^F^^EHR REFERRAL TYPE^^^P^1^^^"  ;5/22/17 BMC*3.1*12 IHS/OIT/FCJ USE LOCAL SYS FOR LOOKUP

 +14      ;5/22/17 BMC*3.1*12

           SET OUT=SNOLST

           SET IN=BMCSNO_"^F^^EHR REFERRAL TYPE^^^P^1^^^1"

 +15       SET X=$$SEARCH^BSTSAPI(OUT,IN)

 +16      ; ERROR

           IF +X=0

               WRITE !,"INVALID RESPONSE"

               GOTO SNO

 +17      ;DISPLAY

 +18       KILL DIR

 +19       SET (CT,L)=0

 +20       FOR 

               SET L=$ORDER(^XTMP("BMCSNO",$JOB,L))

               IF L'?1N.N

                   QUIT 

               SET CT=L

 +21      ;

 +22       FOR L=1:1:CT

               Begin DoDot:1

 +23      ;W !?4,L,".",?8,^XTMP("BMCSNO",$J,L,"PRB","DSC"),?20,^XTMP("BMCSNO",$J,L,"PRB","TRM")

 +24               WRITE !?4,L,".",?8,^XTMP("BMCSNO",$JOB,L,"CON"),?20,^XTMP("BMCSNO",$JOB,L,"FSN","TRM")

 +25               IF L=CT

                       Begin DoDot:2

 +26                       WRITE !

 +27                       SET DIR(0)="L^1:"_L

                           SET DIR("A")="Enter the corresponding number"

                           DO ^DIR

 +28                       IF +X>0

                               SET BMCQ=1

                               SET BMCSNO=X

                       End DoDot:2

                       IF 'BMCQ

                           WRITE !!,"Snomed Clinical Term required."

                           GOTO SNO

 +29               IF L#20=0

                       DO SEL

               End DoDot:1

               IF BMCQ

                   QUIT 

               IF $DATA(DUOUT)

                   GOTO SNO

 +30      ;I BMCSNO>0 S BMCSCOD=^XTMP("BMCSNO",$J,BMCSNO,"PRB","DSC"),BMCSTRM=^XTMP("BMCSNO",$J,BMCSNO,"PRB","TRM")

 +31       IF BMCSNO>0

               SET BMCSCOD=^XTMP("BMCSNO",$JOB,BMCSNO,"CON")

               SET BMCSTRM=^XTMP("BMCSNO",$JOB,BMCSNO,"FSN","TRM")

 +32       KILL DIR

 +33       QUIT 

SEL       ;SELECT

 +1        WRITE !

 +2        SET DIR(0)="LO^1:"_L

 +3        SET DIR("A")="Enter the corresponding number or return to continue"

 +4        DO ^DIR

 +5        IF $DATA(DUOUT)

               WRITE !!,"SNOMED Clinical Term required."

 +6        IF X>0

               SET BMCQ=1

               SET BMCSNO=+X

 +7        WRITE !

 +8        KILL DIR

 +9        QUIT 

 +10      ;

SNOLST    ;LIST THE SNOMED CODES

 +1        NEW DIR

 +2        SET SNOLST=$NAME(^XTMP("BMCSNO",$JOB))

 +3       ;S X=$$SUBLST^BSTSAPI(SNOLST,"EHR REFERRAL TYPE"),L=0    ;5/22/17 BMC*3.1*12 IHS/OIT/FCJ USE LOCAL SYS FOR LOOKUP

 +4       ;5/22/17 BMC*3.1*12

           SET X=$$SUBLST^BSTSAPI(SNOLST,"EHR REFERRAL TYPE^^1")

           SET L=0

 +5       ;5/22/17 BMC*4.0*12 IHS/OIT/FCJ ALPHA LIST OF CODES INSTEAD OF NUMERIC

 +6        FOR 

               SET L=$ORDER(^XTMP("BMCSNO",$JOB,L))

               IF L'?1N.N

                   QUIT 

               SET ^XTMP("BMCSNO",$JOB,"B",$PIECE(^XTMP("BMCSNO",$JOB,L),U,3),L)=""

 +7        SET L=0

           SET L2=0

           FOR 

               SET L=$ORDER(^XTMP("BMCSNO",$JOB,"B",L))

               IF L=""

                   QUIT 

               Begin DoDot:1

 +8                SET L1=0

                   FOR 

                       SET L1=$ORDER(^XTMP("BMCSNO",$JOB,"B",L,L1))

                       IF L1'?1N.N

                           QUIT 

                       Begin DoDot:2

 +9                        WRITE !?5,$PIECE(^XTMP("BMCSNO",$JOB,L1),U),?15,$PIECE(^XTMP("BMCSNO",$JOB,L1),U,3)

                           SET L2=L2+1

 +10      ;W !?5,$P(^XTMP("BMCSNO",$J,L),U),?15,$P(^XTMP("BMCSNO",$J,L),U,3)

 +11                       IF L2#20=0

                               WRITE !

                               SET DIR(0)="E"

                               SET DIR("A")="Press return to continue or '^' to exit list"

                               DO ^DIR

                               WRITE @IOF

                       End DoDot:2

                       IF $DATA(DUOUT)

                           QUIT 

               End DoDot:1

               IF $DATA(DUOUT)

                   QUIT 

 +12      ;5/22/17 BMC*4.0*12 IHS/OIT/FCJ END MODS

 +13       QUIT 

 +14      ;

EXIT      ;EXIT PROGRAM

 +1        KILL X,L,L1,L2,^XTMP("BMCSNO",$JOB)

 +2        SET BMCQ=0

 +3        IF BMCMODE="R"

               IF '$GET(BMCSCOD)

                   SET BMCSCOD=$PIECE($GET(^BMCRTNRF(BMCRREF,13)),U,3)

                   IF BMCSCOD

                       SET BMCSTRM=$PIECE($$CONC^BSTSAPI(BMCSCOD_"^^^1"),U,2)

 +4        QUIT 

GETSNO    ;EP FR BMCMOD AND BMCMODS;GET SNOMED TERM DESCRIPTION

 +1        SET BMCSCOD=""

           SET BMCSTRM=""

           SET BMCVREF=""

 +2        SET BMCVREF=$PIECE($GET(^BMCREF(BMCRIEN,13)),U,3)

 +3       ;BMC*4.0*9 TEST FOR PCC V REF FIRST THEN REF FILE

 +4       ;Q:'BMCVREF

 +5        IF 'BMCVREF

               Begin DoDot:1

 +6                SET BMCSCOD=$PIECE($GET(^BMCREF(BMCRIEN,22,1,0)),U)

 +7                SET BMCSTRM=$PIECE($$CONC^BSTSAPI(BMCSCOD_"^^^1"),U,2)

               End DoDot:1

               QUIT 

 +8        SET BMCSCOD=$PIECE(^AUPNVREF(BMCVREF,0),U)

 +9        SET BMCSTRM=$PIECE($$CONC^BSTSAPI(BMCSCOD_"^^^1"),U,2)

 +10      ;S BMCSTRM=$P($$DESC^BSTSAPI(BMCSCOD),U,2)

 +11       QUIT