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
