GMPLBLDC ; SLC/MKB,TC -- Build Problem Selection Categories ;09/20/17 11:56
;;2.0;Problem List;**3,7,28,36,42,45,49**;Aug 25, 1994;Build 43
;
; External References:
; ICR 2950/6267 LOOK^LEXA
; ICR 4083 $$STATCHK^LEXSRC2
; ICR 5006 $$GETSYN^LEXTRAN1
; ICR 5679 $$ONE^LEXU,$$IMPDATE^LEXU
; ICR 5747 $$CODECS^ICDEX,$$STATCHK^ICDEX
; ICR 10103 $$DT^XLFDT,$$FMTE^XLFDT,$$NOW^XLFDT
; ICR 10104 $$UP^XLFSTR
; ICR 10116 FULL^VALM1
; ICR 10117 CNTRL^VALM10
; ICR 10118 EN^VALM
;
EN ; -- main entry point for GMPL SELECTION GROUP BUILD
D EN^VALM("GMPL SELECTION GROUP BUILD")
Q
;
HDR ; -- header code
N NAME,NUM,DATE S NUM=+^TMP("GMPLST",$J,0)_" problem"_$S(+^TMP("GMPLST",$J,0)'=1:"s",1:"")
S DATE="Last Modified: "_$S(+$P(GMPLGRP,U,3):$$FMTE^XLFDT($P(GMPLGRP,U,3)),1:"<new category>")
S VALMHDR(1)=DATE_$J(NUM,79-$L(DATE))
S NAME=$P(GMPLGRP,U,2),VALMHDR(2)=$J(NAME,$L(NAME)\2+41)
Q
;
INIT ; -- init variables and list array
S GMPLGRP=$$GROUP^GMPLBLD2("L") I GMPLGRP="^" S VALMQUIT=1 Q
L +^GMPL(125.11,+GMPLGRP,0):1 I '$T D G INIT
. W $C(7),!!,"This category is currently being edited by another user!",!
S GMPLMODE="E",VALMSG=$$MSG^GMPLX
D GETLIST,BUILD("^TMP(""GMPLIST"",$J)",GMPLMODE)
Q
;
GETLIST ; Build ^TMP("GMPLIST",$J,#) of problems
N ITEM,PROB,CNT,GMPSEQ,GMPLDA K ^TMP("GMPLIST",$J) S CNT=0
W !,"Searching for the problems ..."
S (GMPSEQ,GMPLDA)=""
F S GMPSEQ=$O(^GMPL(125.11,"C",+GMPLGRP,GMPSEQ)) Q:'GMPSEQ D
. F S GMPLDA=$O(^GMPL(125.11,"C",+GMPLGRP,GMPSEQ,GMPLDA)) Q:'GMPLDA D
. . S ITEM=$G(^GMPL(125.11,+GMPLGRP,1,GMPLDA,0)),PROB=$P(ITEM,U,1)
. . ; prob ^ seq ^ text ^ ICD code ^ snomed ct concept ^ snomed ct designation
. . S ^TMP("GMPLIST",$J,GMPLDA)=$G(ITEM),CNT=CNT+1
. . S (^TMP("GMPLIST",$J,"PROB",PROB),^TMP("GMPLIST",$J,"SEQ",GMPSEQ))=GMPLDA ; Xrefs
S ^TMP("GMPLIST",$J,0)=CNT
Q
;
BUILD(LIST,MODE) ; Build ^TMP("GMPLST",$J,) of current items in LIST for display
N GMPSEQ,GMPIFN,LCNT,NUM,PROB,TEXT,ITEM,GMPDT D CLEAN^VALM10
I $P($G(^TMP("GMPLIST",$J,0)),U,1)'>0 S ^TMP("GMPLST",$J,1,0)=" ",^TMP("GMPLST",$J,2,0)="No items available.",^TMP("GMPLST",$J,0)="0^2",VALMCNT=2 Q
S (LCNT,NUM,GMPSEQ)=0,GMPDT=$$DT^XLFDT
F S GMPSEQ=$O(^TMP("GMPLIST",$J,"SEQ",GMPSEQ)) Q:GMPSEQ'>0 D
. N GMI,GMPLCSYS,GMPLCPTR,GMPSCT,GMPSCTC,GMPICD,GMPICDC,GMPCSYS
. S (GMPSCT,GMPICD)=0,LCNT=LCNT+1,NUM=NUM+1
. S GMPIFN=$G(^TMP("GMPLIST",$J,"SEQ",GMPSEQ))
. S PROB=$P(^TMP("GMPLIST",$J,GMPIFN),U,1),TEXT=$P(^TMP("GMPLIST",$J,GMPIFN),U,3)
. S GMPICDC=$P(^TMP("GMPLIST",$J,GMPIFN),U,4),GMPSCTC=$P(^TMP("GMPLIST",$J,GMPIFN),U,5)
. S ^TMP("GMPLST",$J,LCNT,0)=$S(MODE="I":"<"_GMPSEQ_">",1:" ")_$J(NUM,3)_" "_TEXT
. I $L(GMPSCTC) D
. . I $$STATCHK^LEXSRC2(GMPSCTC,GMPDT,"","SCT") Q
. . S GMPSCT=1
. I $L(GMPICDC) D
. . S ^TMP("GMPLST",$J,LCNT,0)=^TMP("GMPLST",$J,LCNT,0)_" ("_$P($$CODECS^ICDEX($P(GMPICDC,"/"),80,GMPDT),U,2)_" "_GMPICDC_")"
. . F GMI=1:1:$L(GMPICDC,"/") D
. . . N GMPLCPTR S GMPLCPTR=$P($$CODECS^ICDEX($P(GMPICDC,"/",GMI),80,GMPDT),U)
. . . I $$STATCHK^ICDEX($P(GMPICDC,"/",GMI),GMPDT,GMPLCPTR) Q ; OK - code is active
. . . S GMPICD=1
. S GMPCSYS=$S(GMPSCT:"SCT",GMPICD:"ICD",(GMPSCT&GMPICD):"SCT/ICD",1:"")
. S:GMPCSYS'="" ^TMP("GMPLST",$J,LCNT,0)=^TMP("GMPLST",$J,LCNT,0)_" <INACTIVE "_GMPCSYS_" CODE>"
. D CNTRL^VALM10(LCNT,6,1,IOINHI,IOINORM)
. S ^TMP("GMPLST",$J,"B",NUM)=GMPIFN
S ^TMP("GMPLST",$J,0)=NUM_U_LCNT,VALMCNT=LCNT
Q
;
HELP ; -- help code
N X
W !!?4,"You may take a variety of actions from this prompt. To update"
W !?4,"this category you may add new problems or remove an existing"
W !?4,"one; you may also change the text or code displayed, or the order"
W !?4,"in which each problem is displayed. Select View w/wo Seq Numbers"
W !?4,"to toggle seeing the sequence number in addition to the display"
W !?4,"number per problem. If necessary, the current category may be"
W !?4,"deleted; you may change to a different category to continue editing."
W !!,"Press <return> to continue ..." R X:DTIME
S VALMSG=$$MSG^GMPLX,VALMBCK=$S(VALMCC:"",1:"R")
Q
;
EXIT ; -- exit code
N GMPDT
I $D(GMPLSAVE),$$CKSAVE^GMPLBLD2 D
. S GMPDT=$$DT^XLFDT
. D SAVE^GMPLBLD2
. S ^GMPL(125.11,+GMPLGRP,0)=$P(GMPLGRP,U,2)_U_GMPDT_U_$P(GMPLGRP,U,4)
L -^GMPL(125.11,+GMPLGRP,0)
K GMPLIST,GMPLST,GMPLMODE,GMPLGRP,GMPLSAVE,GMPREBLD,GMPQUIT,RT1,TMPITEM
K VALMBCK,VALMCNT,VALMSG,VALMHDR
K ^TMP("GMPLIST",$J),^TMP("GMPLST",$J)
Q
;
ADD ; Add new problem(s)
N GMPVOCAB,GMPQUIT,GMPREBLD,GMPIMPDT S VALMBCK="" D FULL^VALM1
S GMPVOCAB="" ; $$VOCAB^GMPLX1 Q:GMPVOCAB="^"
I $P($G(GMPLGRP),U,4)="N" W !!,"Cannot make edits to a National category." H 2 Q
S GMPIMPDT=$$IMPDATE^LEXU("10D")
F D Q:$D(GMPQUIT) W !!
ASKAG . N X,Y,GMPLSEQ,GMPLCODE,GMPLIFN,GMPLSCTT,GMPLSCTC,GMPLSCTD
. N GMPLDUP,GMPLTERM,GMPLICD,GMPTYP,GMPNUM,GMPQT,GMPSYN,GMPDT,GMPROB
. S (X,Y,GMPLSCTT,GMPLSCTC,GMPLSCTD,GMPTYP)="",(GMPNUM,GMPQT)=0
. D SEARCH^GMPLX(.X,.Y,"PROBLEM: ","1",GMPVOCAB)
. S GMPDT=$$DT^XLFDT
. I +Y'>0 S GMPQUIT=1 Q
. S GMPLDUP=$$DUPL(.Y,X)
. I GMPLDUP S (Y,GMPROB)="" W !,X,!,"is already on the selection list. Please enter another search term to add." G ASKAG
. S GMPLTERM=$S(+$G(Y)>1:Y,1:""),GMPLICD=$G(Y(1))
. S:'$L(GMPLICD) GMPLICD=$S(GMPDT<GMPIMPDT:"799.9",1:"R69.")
. N GMPLI,GMPSTAT,GMPCSREC,GMPCSPTR,GMPCSNME,GMPLRSLT,GMPLRT1
. I GMPLICD["/" F GMPLI=1:1:$L(GMPLICD,"/") D Q:GMPSTAT
. . N GMPCODE S GMPCODE=$P(GMPLICD,"/",GMPLI),GMPSTAT=0
. . S GMPCSREC=$$CODECS^ICDEX(GMPCODE,80,GMPDT),GMPCSPTR=$P(GMPCSREC,U),GMPCSNME=$P(GMPCSREC,U,2)
. . S:'+$$STATCHK^ICDEX(GMPCODE,GMPDT,GMPCSPTR) GMPSTAT=1
. E D
. . S GMPSTAT=0,GMPCSREC=$$CODECS^ICDEX(GMPLICD,80,GMPDT),GMPCSPTR=$P(GMPCSREC,U),GMPCSNME=$P(GMPCSREC,U,2)
. . S:'+$$STATCHK^ICDEX(GMPLICD,GMPDT,GMPCSPTR) GMPSTAT=1
. I GMPSTAT W !,X,!,"has an inactive ICD code. Please enter another search term to add." G ASKAG
. I X["(SCT" D
. . S GMPLSCTT=$P(X," (SCT ")
. . S GMPLSCTC=$$ONE^LEXU(+GMPLTERM,GMPDT,"SCT")
. . S GMPLRSLT=$$GETSYN^LEXTRAN1("SCT",GMPLSCTC,GMPDT,"GMPSYN",1,1)
. . I +GMPLRSLT<0 S GMPLSCTD="" Q
. . S GMPLSCTT=$$STRIPSPC^GMPLX(GMPLSCTT)
. . F S GMPTYP=$O(GMPSYN(GMPTYP)) Q:GMPTYP=""!(GMPQT) D
. . . I GMPTYP="S" F S GMPNUM=$O(GMPSYN(GMPTYP,GMPNUM)) Q:GMPNUM=""!(GMPQT) D
. . . . I $$STRIPSPC^GMPLX($P(GMPSYN(GMPTYP,GMPNUM),U))=GMPLSCTT S GMPLSCTD=$P(GMPSYN(GMPTYP,GMPNUM),U,3),GMPQT=1 Q
. . . I (GMPNUM=""),(GMPLSCTD="") S GMPQT=1 Q
. . . Q:GMPQT
. . . I $$STRIPSPC^GMPLX($P(GMPSYN(GMPTYP),U))=GMPLSCTT S GMPLSCTD=$P(GMPSYN(GMPTYP),U,3),GMPQT=1 Q
. W !!," DISPLAY TEXT: "_X
. S GMPLCODE=$$CODE^GMPLBLD1($G(GMPLSCTC),$G(Y(1))) I GMPLCODE']"" S GMPQUIT=1 Q
. S GMPLRT1="^TMP(""GMPLIST"",$J,""SEQ"",",GMPLSEQ=+$$LAST^GMPLBLD2(GMPLRT1)+1 ; dflt = next #
. S GMPLSEQ=$$SEQ^GMPLBLD1(GMPLSEQ) I GMPLSEQ="^" S GMPQUIT=1 Q
. S GMPLIFN=$$TMPIFN^GMPLBLD1,^TMP("GMPLIST",$J,0)=^TMP("GMPLIST",$J,0)+1
. S ^TMP("GMPLIST",$J,GMPLIFN)=+Y_U_GMPLSEQ_U_X_U_GMPLCODE_U_GMPLSCTC_U_GMPLSCTD ; prob ^ seq ^ text ^ code ^ snomed ct concept ^ snomed ct designation
. S (^TMP("GMPLIST",$J,"PROB",+Y),^TMP("GMPLIST",$J,"SEQ",GMPLSEQ))=GMPLIFN,GMPREBLD=1
I $D(GMPREBLD) S VALMBCK="R",GMPLSAVE=1 D BUILD("^TMP(""GMPLIST"",$J)",GMPLMODE),HDR
S VALMBCK="R" S VALMSG=$$MSG^GMPLX K GMPSYN
Q
;
COPY ; Copy an existing category into a new category
N GMPVAL
D COPYCAT^GMPLCOPY(.GMPVAL)
I $D(GMPVAL) S GMPLGRP=GMPVAL
S VALMBCK="R",VALMSG=$$MSG^GMPLX
D GETLIST,BUILD("^TMP(""GMPLIST"",$J)",GMPLMODE),HDR
Q
;
REMOVE ; Remove problem from group
N NUM,IFN S VALMBCK=""
I $P($G(GMPLGRP),U,4)="N" W !!,"Cannot make edits to a National category." H 2 G RMQ
S NUM=$$SEL1^GMPLBLD1 G:NUM="^" RMQ
S IFN=$P($G(^TMP("GMPLST",$J,"B",NUM)),U,1) G:+IFN'>0 RMQ
I "@"[$G(^TMP("GMPLIST",$J,IFN)) W $C(7),!!,"Problem does not exist in this category!" H 2 G RMQ
I '$$SURE^GMPLX W !?5,"< Nothing removed! >" H 1 G RMQ
D DELETE^GMPLBLD1(IFN) S VALMBCK="R",GMPLSAVE=1
D BUILD("^TMP(""GMPLIST"",$J)",GMPLMODE),HDR
RMQ S:'VALMCC VALMBCK="R" S VALMSG=$$MSG^GMPLX
Q
;
EDIT ; Edit problem text and code
N NUM,SEL,IFN,PIECE,CODE,PROB,PROBLEM,GMPQUIT,GMPREBLD S VALMBCK="" D FULL^VALM1
I $P($G(GMPLGRP),U,4)="N" W !!,"Cannot make edits to a National category." H 2 G EDQ
S SEL=$$SEL^GMPLBLD1 G:SEL="^" EDQ
F PIECE=1:1:$L(SEL,",") D Q:$D(GMPQUIT) W !
. S NUM=$P(SEL,",",PIECE) Q:NUM'>0
. S IFN=$P($G(^TMP("GMPLST",$J,"B",NUM)),U,1) Q:IFN'>0
. I "@"[$G(^TMP("GMPLIST",$J,IFN)) W $C(7),!!,"Problem #"_NUM_" does not exist in this category!" H 2 Q
. W !!,">>> Problem #"_NUM S PROBLEM=^TMP("GMPLIST",$J,IFN)
. W:$P(PROBLEM,U,1)>1 " = "_$G(^LEX(757.01,+$P(PROBLEM,U,1),0)) W ! ; KER
. S PROB=$$TEXT^GMPLBLD1($P(PROBLEM,U,3)) I PROB="^" S GMPQUIT=1 Q
. I PROB="@" D DELETE^GMPLBLD1(IFN) S GMPREBLD=1 Q
. S CODE=$$CODE^GMPLBLD1($P(PROBLEM,U,5),$P(PROBLEM,U,4)) I CODE="^" S GMPQUIT=1 Q
. S ^TMP("GMPLIST",$J,IFN)=$P(PROBLEM,U,1,2)_U_PROB_U_CODE_U_$P(PROBLEM,U,5,6),GMPREBLD=1
I $D(GMPREBLD) S VALMBCK="R",GMPLSAVE=1 D BUILD("^TMP(""GMPLIST"",$J)",GMPLMODE)
EDQ S:'VALMCC VALMBCK="R" S VALMSG=$$MSG^GMPLX
Q
;
DUPL(Y,TEXT) ; Check for Duplicates within problem selection list category
N DA,IFN,GMPOTHR,GMPNOW,GMPSRC,GMPCODE,SCTCNEW,ICDNEW,PICDNEW
S DA=0
I '$D(^TMP("GMPLIST")) G DUPLX
S GMPNOW=$E($$NOW^XLFDT,1,7)
S GMPOTHR=$S(GMPNOW<($$IMPDATE^LEXU("10D")):"799.9",1:"R69.")
D EXP2CODE^GMPLX(+Y,.GMPSRC,.GMPCODE)
S SCTCNEW=$S(GMPSRC="SNOMED CT"&($D(GMPCODE)):GMPCODE,1:$P($P(TEXT," (SCT ",2),")"))
S ICDNEW=$S(GMPSRC="SNOMED CT":$G(Y(1)),1:GMPCODE),PICDNEW=$P(ICDNEW,"/")
S IFN=""
F S IFN=$O(^TMP("GMPLIST",$J,IFN)) Q:IFN="" D Q:DA>0
.N PICDEXT,ICDEXT,SLST,SCTCEXT,TERMEXT,EXPTXT
.S SLST=$G(^TMP("GMPLIST",$J,IFN)),SCTCEXT=$P(SLST,U,5)
.S ICDEXT=$P(SLST,U,4),PICDEXT=$P(ICDEXT,"/")
.S TERMEXT=$P(SLST,U,1)
.;Compare problems with SNOMED CT concept codes & ICD code(s) only
.I $L(SCTCEXT),(GMPSRC="SNOMED CT"),($G(SCTCNEW)>0),($L(ICDNEW)) D
..;if SCT concepts & primary + multiple ICD targets match => dup
..I ICDEXT["/",ICDNEW["/" D
...N I,J,SICDEXT S J=0 F I=2:1:$L(ICDEXT,"/") D
....S J=J+1,SICDEXT(J)=$P(ICDEXT,"/",I)
...N K,L,SICDNEW S L=0 F K=2:1:$L(ICDNEW,"/") D
....S L=L+1,SICDNEW(L)=$P(ICDNEW,"/",K)
...N T F T=1:1:L D
....I SCTCEXT=SCTCNEW,(PICDEXT=PICDNEW),SICDEXT(T)=SICDNEW(T) S DA=IFN Q
..;if SCT concept codes match => dup
..E I ICDNEW=GMPOTHR!(PICDNEW=GMPOTHR) D
...I SCTCEXT=SCTCNEW S DA=IFN Q
..;if SCT concepts & primary ICD diagnosis match => dup
..E I SCTCEXT=SCTCNEW,(PICDEXT=PICDNEW) S DA=IFN Q
.;Compare legacy problems with ICD codes only
.E I $L(ICDEXT),'$L(SCTCEXT),(GMPSRC["ICD"),(+$G(ICDNEW)>0) D
..;if Exprs match => dup
..I +Y>1&(TERMEXT=+Y) S DA=IFN Q
..;if Text matches Expr from old => dup
..D LOOK^LEXA("`"_TERMEXT)
..S EXPTXT=$P($G(LEX("LIST",1)),U,2)
..S TEXT=$$UP^XLFSTR($P(TEXT," (ICD"))
..I LEX>1&(TEXT=$$UP^XLFSTR($S(EXPTXT["*":$P(EXPTXT," *"),1:EXPTXT))) S DA=IFN Q
..;if prim ICD of new = prim ICD of old => dup
..I PICDEXT'=GMPOTHR,(PICDNEW'=GMPOTHR),(PICDEXT=PICDNEW) S DA=IFN Q
DUPLX Q DA
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMPLBLDC 11328 printed Apr 09, 2024@21:32:44 Page 2
GMPLBLDC ; SLC/MKB,TC -- Build Problem Selection Categories ;09/20/17 11:56
+1 ;;2.0;Problem List;**3,7,28,36,42,45,49**;Aug 25, 1994;Build 43
+2 ;
+3 ; External References:
+4 ; ICR 2950/6267 LOOK^LEXA
+5 ; ICR 4083 $$STATCHK^LEXSRC2
+6 ; ICR 5006 $$GETSYN^LEXTRAN1
+7 ; ICR 5679 $$ONE^LEXU,$$IMPDATE^LEXU
+8 ; ICR 5747 $$CODECS^ICDEX,$$STATCHK^ICDEX
+9 ; ICR 10103 $$DT^XLFDT,$$FMTE^XLFDT,$$NOW^XLFDT
+10 ; ICR 10104 $$UP^XLFSTR
+11 ; ICR 10116 FULL^VALM1
+12 ; ICR 10117 CNTRL^VALM10
+13 ; ICR 10118 EN^VALM
+14 ;
EN ; -- main entry point for GMPL SELECTION GROUP BUILD
+1 DO EN^VALM("GMPL SELECTION GROUP BUILD")
+2 QUIT
+3 ;
HDR ; -- header code
+1 NEW NAME,NUM,DATE
SET NUM=+^TMP("GMPLST",$JOB,0)_" problem"_$SELECT(+^TMP("GMPLST",$JOB,0)'=1:"s",1:"")
+2 SET DATE="Last Modified: "_$SELECT(+$PIECE(GMPLGRP,U,3):$$FMTE^XLFDT($PIECE(GMPLGRP,U,3)),1:"<new category>")
+3 SET VALMHDR(1)=DATE_$JUSTIFY(NUM,79-$LENGTH(DATE))
+4 SET NAME=$PIECE(GMPLGRP,U,2)
SET VALMHDR(2)=$JUSTIFY(NAME,$LENGTH(NAME)\2+41)
+5 QUIT
+6 ;
INIT ; -- init variables and list array
+1 SET GMPLGRP=$$GROUP^GMPLBLD2("L")
IF GMPLGRP="^"
SET VALMQUIT=1
QUIT
+2 LOCK +^GMPL(125.11,+GMPLGRP,0):1
IF '$TEST
Begin DoDot:1
+3 WRITE $CHAR(7),!!,"This category is currently being edited by another user!",!
End DoDot:1
GOTO INIT
+4 SET GMPLMODE="E"
SET VALMSG=$$MSG^GMPLX
+5 DO GETLIST
DO BUILD("^TMP(""GMPLIST"",$J)",GMPLMODE)
+6 QUIT
+7 ;
GETLIST ; Build ^TMP("GMPLIST",$J,#) of problems
+1 NEW ITEM,PROB,CNT,GMPSEQ,GMPLDA
KILL ^TMP("GMPLIST",$JOB)
SET CNT=0
+2 WRITE !,"Searching for the problems ..."
+3 SET (GMPSEQ,GMPLDA)=""
+4 FOR
SET GMPSEQ=$ORDER(^GMPL(125.11,"C",+GMPLGRP,GMPSEQ))
if 'GMPSEQ
QUIT
Begin DoDot:1
+5 FOR
SET GMPLDA=$ORDER(^GMPL(125.11,"C",+GMPLGRP,GMPSEQ,GMPLDA))
if 'GMPLDA
QUIT
Begin DoDot:2
+6 SET ITEM=$GET(^GMPL(125.11,+GMPLGRP,1,GMPLDA,0))
SET PROB=$PIECE(ITEM,U,1)
+7 ; prob ^ seq ^ text ^ ICD code ^ snomed ct concept ^ snomed ct designation
+8 SET ^TMP("GMPLIST",$JOB,GMPLDA)=$GET(ITEM)
SET CNT=CNT+1
+9 ; Xrefs
SET (^TMP("GMPLIST",$JOB,"PROB",PROB),^TMP("GMPLIST",$JOB,"SEQ",GMPSEQ))=GMPLDA
End DoDot:2
End DoDot:1
+10 SET ^TMP("GMPLIST",$JOB,0)=CNT
+11 QUIT
+12 ;
BUILD(LIST,MODE) ; Build ^TMP("GMPLST",$J,) of current items in LIST for display
+1 NEW GMPSEQ,GMPIFN,LCNT,NUM,PROB,TEXT,ITEM,GMPDT
DO CLEAN^VALM10
+2 IF $PIECE($GET(^TMP("GMPLIST",$JOB,0)),U,1)'>0
SET ^TMP("GMPLST",$JOB,1,0)=" "
SET ^TMP("GMPLST",$JOB,2,0)="No items available."
SET ^TMP("GMPLST",$JOB,0)="0^2"
SET VALMCNT=2
QUIT
+3 SET (LCNT,NUM,GMPSEQ)=0
SET GMPDT=$$DT^XLFDT
+4 FOR
SET GMPSEQ=$ORDER(^TMP("GMPLIST",$JOB,"SEQ",GMPSEQ))
if GMPSEQ'>0
QUIT
Begin DoDot:1
+5 NEW GMI,GMPLCSYS,GMPLCPTR,GMPSCT,GMPSCTC,GMPICD,GMPICDC,GMPCSYS
+6 SET (GMPSCT,GMPICD)=0
SET LCNT=LCNT+1
SET NUM=NUM+1
+7 SET GMPIFN=$GET(^TMP("GMPLIST",$JOB,"SEQ",GMPSEQ))
+8 SET PROB=$PIECE(^TMP("GMPLIST",$JOB,GMPIFN),U,1)
SET TEXT=$PIECE(^TMP("GMPLIST",$JOB,GMPIFN),U,3)
+9 SET GMPICDC=$PIECE(^TMP("GMPLIST",$JOB,GMPIFN),U,4)
SET GMPSCTC=$PIECE(^TMP("GMPLIST",$JOB,GMPIFN),U,5)
+10 SET ^TMP("GMPLST",$JOB,LCNT,0)=$SELECT(MODE="I":"<"_GMPSEQ_">",1:" ")_$JUSTIFY(NUM,3)_" "_TEXT
+11 IF $LENGTH(GMPSCTC)
Begin DoDot:2
+12 IF $$STATCHK^LEXSRC2(GMPSCTC,GMPDT,"","SCT")
QUIT
+13 SET GMPSCT=1
End DoDot:2
+14 IF $LENGTH(GMPICDC)
Begin DoDot:2
+15 SET ^TMP("GMPLST",$JOB,LCNT,0)=^TMP("GMPLST",$JOB,LCNT,0)_" ("_$PIECE($$CODECS^ICDEX($PIECE(GMPICDC,"/"),80,GMPDT),U,2)_" "_GMPICDC_")"
+16 FOR GMI=1:1:$LENGTH(GMPICDC,"/")
Begin DoDot:3
+17 NEW GMPLCPTR
SET GMPLCPTR=$PIECE($$CODECS^ICDEX($PIECE(GMPICDC,"/",GMI),80,GMPDT),U)
+18 ; OK - code is active
IF $$STATCHK^ICDEX($PIECE(GMPICDC,"/",GMI),GMPDT,GMPLCPTR)
QUIT
+19 SET GMPICD=1
End DoDot:3
End DoDot:2
+20 SET GMPCSYS=$SELECT(GMPSCT:"SCT",GMPICD:"ICD",(GMPSCT&GMPICD):"SCT/ICD",1:"")
+21 if GMPCSYS'=""
SET ^TMP("GMPLST",$JOB,LCNT,0)=^TMP("GMPLST",$JOB,LCNT,0)_" <INACTIVE "_GMPCSYS_" CODE>"
+22 DO CNTRL^VALM10(LCNT,6,1,IOINHI,IOINORM)
+23 SET ^TMP("GMPLST",$JOB,"B",NUM)=GMPIFN
End DoDot:1
+24 SET ^TMP("GMPLST",$JOB,0)=NUM_U_LCNT
SET VALMCNT=LCNT
+25 QUIT
+26 ;
HELP ; -- help code
+1 NEW X
+2 WRITE !!?4,"You may take a variety of actions from this prompt. To update"
+3 WRITE !?4,"this category you may add new problems or remove an existing"
+4 WRITE !?4,"one; you may also change the text or code displayed, or the order"
+5 WRITE !?4,"in which each problem is displayed. Select View w/wo Seq Numbers"
+6 WRITE !?4,"to toggle seeing the sequence number in addition to the display"
+7 WRITE !?4,"number per problem. If necessary, the current category may be"
+8 WRITE !?4,"deleted; you may change to a different category to continue editing."
+9 WRITE !!,"Press <return> to continue ..."
READ X:DTIME
+10 SET VALMSG=$$MSG^GMPLX
SET VALMBCK=$SELECT(VALMCC:"",1:"R")
+11 QUIT
+12 ;
EXIT ; -- exit code
+1 NEW GMPDT
+2 IF $DATA(GMPLSAVE)
IF $$CKSAVE^GMPLBLD2
Begin DoDot:1
+3 SET GMPDT=$$DT^XLFDT
+4 DO SAVE^GMPLBLD2
+5 SET ^GMPL(125.11,+GMPLGRP,0)=$PIECE(GMPLGRP,U,2)_U_GMPDT_U_$PIECE(GMPLGRP,U,4)
End DoDot:1
+6 LOCK -^GMPL(125.11,+GMPLGRP,0)
+7 KILL GMPLIST,GMPLST,GMPLMODE,GMPLGRP,GMPLSAVE,GMPREBLD,GMPQUIT,RT1,TMPITEM
+8 KILL VALMBCK,VALMCNT,VALMSG,VALMHDR
+9 KILL ^TMP("GMPLIST",$JOB),^TMP("GMPLST",$JOB)
+10 QUIT
+11 ;
ADD ; Add new problem(s)
+1 NEW GMPVOCAB,GMPQUIT,GMPREBLD,GMPIMPDT
SET VALMBCK=""
DO FULL^VALM1
+2 ; $$VOCAB^GMPLX1 Q:GMPVOCAB="^"
SET GMPVOCAB=""
+3 IF $PIECE($GET(GMPLGRP),U,4)="N"
WRITE !!,"Cannot make edits to a National category."
HANG 2
QUIT
+4 SET GMPIMPDT=$$IMPDATE^LEXU("10D")
+5 FOR
Begin DoDot:1
ASKAG NEW X,Y,GMPLSEQ,GMPLCODE,GMPLIFN,GMPLSCTT,GMPLSCTC,GMPLSCTD
+1 NEW GMPLDUP,GMPLTERM,GMPLICD,GMPTYP,GMPNUM,GMPQT,GMPSYN,GMPDT,GMPROB
+2 SET (X,Y,GMPLSCTT,GMPLSCTC,GMPLSCTD,GMPTYP)=""
SET (GMPNUM,GMPQT)=0
+3 DO SEARCH^GMPLX(.X,.Y,"PROBLEM: ","1",GMPVOCAB)
+4 SET GMPDT=$$DT^XLFDT
+5 IF +Y'>0
SET GMPQUIT=1
QUIT
+6 SET GMPLDUP=$$DUPL(.Y,X)
+7 IF GMPLDUP
SET (Y,GMPROB)=""
WRITE !,X,!,"is already on the selection list. Please enter another search term to add."
GOTO ASKAG
+8 SET GMPLTERM=$SELECT(+$GET(Y)>1:Y,1:"")
SET GMPLICD=$GET(Y(1))
+9 if '$LENGTH(GMPLICD)
SET GMPLICD=$SELECT(GMPDT<GMPIMPDT:"799.9",1:"R69.")
+10 NEW GMPLI,GMPSTAT,GMPCSREC,GMPCSPTR,GMPCSNME,GMPLRSLT,GMPLRT1
+11 IF GMPLICD["/"
FOR GMPLI=1:1:$LENGTH(GMPLICD,"/")
Begin DoDot:2
+12 NEW GMPCODE
SET GMPCODE=$PIECE(GMPLICD,"/",GMPLI)
SET GMPSTAT=0
+13 SET GMPCSREC=$$CODECS^ICDEX(GMPCODE,80,GMPDT)
SET GMPCSPTR=$PIECE(GMPCSREC,U)
SET GMPCSNME=$PIECE(GMPCSREC,U,2)
+14 if '+$$STATCHK^ICDEX(GMPCODE,GMPDT,GMPCSPTR)
SET GMPSTAT=1
End DoDot:2
if GMPSTAT
QUIT
+15 IF '$TEST
Begin DoDot:2
+16 SET GMPSTAT=0
SET GMPCSREC=$$CODECS^ICDEX(GMPLICD,80,GMPDT)
SET GMPCSPTR=$PIECE(GMPCSREC,U)
SET GMPCSNME=$PIECE(GMPCSREC,U,2)
+17 if '+$$STATCHK^ICDEX(GMPLICD,GMPDT,GMPCSPTR)
SET GMPSTAT=1
End DoDot:2
+18 IF GMPSTAT
WRITE !,X,!,"has an inactive ICD code. Please enter another search term to add."
GOTO ASKAG
+19 IF X["(SCT"
Begin DoDot:2
+20 SET GMPLSCTT=$PIECE(X," (SCT ")
+21 SET GMPLSCTC=$$ONE^LEXU(+GMPLTERM,GMPDT,"SCT")
+22 SET GMPLRSLT=$$GETSYN^LEXTRAN1("SCT",GMPLSCTC,GMPDT,"GMPSYN",1,1)
+23 IF +GMPLRSLT<0
SET GMPLSCTD=""
QUIT
+24 SET GMPLSCTT=$$STRIPSPC^GMPLX(GMPLSCTT)
+25 FOR
SET GMPTYP=$ORDER(GMPSYN(GMPTYP))
if GMPTYP=""!(GMPQT)
QUIT
Begin DoDot:3
+26 IF GMPTYP="S"
FOR
SET GMPNUM=$ORDER(GMPSYN(GMPTYP,GMPNUM))
if GMPNUM=""!(GMPQT)
QUIT
Begin DoDot:4
+27 IF $$STRIPSPC^GMPLX($PIECE(GMPSYN(GMPTYP,GMPNUM),U))=GMPLSCTT
SET GMPLSCTD=$PIECE(GMPSYN(GMPTYP,GMPNUM),U,3)
SET GMPQT=1
QUIT
End DoDot:4
+28 IF (GMPNUM="")
IF (GMPLSCTD="")
SET GMPQT=1
QUIT
+29 if GMPQT
QUIT
+30 IF $$STRIPSPC^GMPLX($PIECE(GMPSYN(GMPTYP),U))=GMPLSCTT
SET GMPLSCTD=$PIECE(GMPSYN(GMPTYP),U,3)
SET GMPQT=1
QUIT
End DoDot:3
End DoDot:2
+31 WRITE !!," DISPLAY TEXT: "_X
+32 SET GMPLCODE=$$CODE^GMPLBLD1($GET(GMPLSCTC),$GET(Y(1)))
IF GMPLCODE']""
SET GMPQUIT=1
QUIT
+33 ; dflt = next #
SET GMPLRT1="^TMP(""GMPLIST"",$J,""SEQ"","
SET GMPLSEQ=+$$LAST^GMPLBLD2(GMPLRT1)+1
+34 SET GMPLSEQ=$$SEQ^GMPLBLD1(GMPLSEQ)
IF GMPLSEQ="^"
SET GMPQUIT=1
QUIT
+35 SET GMPLIFN=$$TMPIFN^GMPLBLD1
SET ^TMP("GMPLIST",$JOB,0)=^TMP("GMPLIST",$JOB,0)+1
+36 ; prob ^ seq ^ text ^ code ^ snomed ct concept ^ snomed ct designation
SET ^TMP("GMPLIST",$JOB,GMPLIFN)=+Y_U_GMPLSEQ_U_X_U_GMPLCODE_U_GMPLSCTC_U_GMPLSCTD
+37 SET (^TMP("GMPLIST",$JOB,"PROB",+Y),^TMP("GMPLIST",$JOB,"SEQ",GMPLSEQ))=GMPLIFN
SET GMPREBLD=1
End DoDot:1
if $DATA(GMPQUIT)
QUIT
WRITE !!
+38 IF $DATA(GMPREBLD)
SET VALMBCK="R"
SET GMPLSAVE=1
DO BUILD("^TMP(""GMPLIST"",$J)",GMPLMODE)
DO HDR
+39 SET VALMBCK="R"
SET VALMSG=$$MSG^GMPLX
KILL GMPSYN
+40 QUIT
+41 ;
COPY ; Copy an existing category into a new category
+1 NEW GMPVAL
+2 DO COPYCAT^GMPLCOPY(.GMPVAL)
+3 IF $DATA(GMPVAL)
SET GMPLGRP=GMPVAL
+4 SET VALMBCK="R"
SET VALMSG=$$MSG^GMPLX
+5 DO GETLIST
DO BUILD("^TMP(""GMPLIST"",$J)",GMPLMODE)
DO HDR
+6 QUIT
+7 ;
REMOVE ; Remove problem from group
+1 NEW NUM,IFN
SET VALMBCK=""
+2 IF $PIECE($GET(GMPLGRP),U,4)="N"
WRITE !!,"Cannot make edits to a National category."
HANG 2
GOTO RMQ
+3 SET NUM=$$SEL1^GMPLBLD1
if NUM="^"
GOTO RMQ
+4 SET IFN=$PIECE($GET(^TMP("GMPLST",$JOB,"B",NUM)),U,1)
if +IFN'>0
GOTO RMQ
+5 IF "@"[$GET(^TMP("GMPLIST",$JOB,IFN))
WRITE $CHAR(7),!!,"Problem does not exist in this category!"
HANG 2
GOTO RMQ
+6 IF '$$SURE^GMPLX
WRITE !?5,"< Nothing removed! >"
HANG 1
GOTO RMQ
+7 DO DELETE^GMPLBLD1(IFN)
SET VALMBCK="R"
SET GMPLSAVE=1
+8 DO BUILD("^TMP(""GMPLIST"",$J)",GMPLMODE)
DO HDR
RMQ if 'VALMCC
SET VALMBCK="R"
SET VALMSG=$$MSG^GMPLX
+1 QUIT
+2 ;
EDIT ; Edit problem text and code
+1 NEW NUM,SEL,IFN,PIECE,CODE,PROB,PROBLEM,GMPQUIT,GMPREBLD
SET VALMBCK=""
DO FULL^VALM1
+2 IF $PIECE($GET(GMPLGRP),U,4)="N"
WRITE !!,"Cannot make edits to a National category."
HANG 2
GOTO EDQ
+3 SET SEL=$$SEL^GMPLBLD1
if SEL="^"
GOTO EDQ
+4 FOR PIECE=1:1:$LENGTH(SEL,",")
Begin DoDot:1
+5 SET NUM=$PIECE(SEL,",",PIECE)
if NUM'>0
QUIT
+6 SET IFN=$PIECE($GET(^TMP("GMPLST",$JOB,"B",NUM)),U,1)
if IFN'>0
QUIT
+7 IF "@"[$GET(^TMP("GMPLIST",$JOB,IFN))
WRITE $CHAR(7),!!,"Problem #"_NUM_" does not exist in this category!"
HANG 2
QUIT
+8 WRITE !!,">>> Problem #"_NUM
SET PROBLEM=^TMP("GMPLIST",$JOB,IFN)
+9 ; KER
if $PIECE(PROBLEM,U,1)>1
WRITE " = "_$GET(^LEX(757.01,+$PIECE(PROBLEM,U,1),0))
WRITE !
+10 SET PROB=$$TEXT^GMPLBLD1($PIECE(PROBLEM,U,3))
IF PROB="^"
SET GMPQUIT=1
QUIT
+11 IF PROB="@"
DO DELETE^GMPLBLD1(IFN)
SET GMPREBLD=1
QUIT
+12 SET CODE=$$CODE^GMPLBLD1($PIECE(PROBLEM,U,5),$PIECE(PROBLEM,U,4))
IF CODE="^"
SET GMPQUIT=1
QUIT
+13 SET ^TMP("GMPLIST",$JOB,IFN)=$PIECE(PROBLEM,U,1,2)_U_PROB_U_CODE_U_$PIECE(PROBLEM,U,5,6)
SET GMPREBLD=1
End DoDot:1
if $DATA(GMPQUIT)
QUIT
WRITE !
+14 IF $DATA(GMPREBLD)
SET VALMBCK="R"
SET GMPLSAVE=1
DO BUILD("^TMP(""GMPLIST"",$J)",GMPLMODE)
EDQ if 'VALMCC
SET VALMBCK="R"
SET VALMSG=$$MSG^GMPLX
+1 QUIT
+2 ;
DUPL(Y,TEXT) ; Check for Duplicates within problem selection list category
+1 NEW DA,IFN,GMPOTHR,GMPNOW,GMPSRC,GMPCODE,SCTCNEW,ICDNEW,PICDNEW
+2 SET DA=0
+3 IF '$DATA(^TMP("GMPLIST"))
GOTO DUPLX
+4 SET GMPNOW=$EXTRACT($$NOW^XLFDT,1,7)
+5 SET GMPOTHR=$SELECT(GMPNOW<($$IMPDATE^LEXU("10D")):"799.9",1:"R69.")
+6 DO EXP2CODE^GMPLX(+Y,.GMPSRC,.GMPCODE)
+7 SET SCTCNEW=$SELECT(GMPSRC="SNOMED CT"&($DATA(GMPCODE)):GMPCODE,1:$PIECE($PIECE(TEXT," (SCT ",2),")"))
+8 SET ICDNEW=$SELECT(GMPSRC="SNOMED CT":$GET(Y(1)),1:GMPCODE)
SET PICDNEW=$PIECE(ICDNEW,"/")
+9 SET IFN=""
+10 FOR
SET IFN=$ORDER(^TMP("GMPLIST",$JOB,IFN))
if IFN=""
QUIT
Begin DoDot:1
+11 NEW PICDEXT,ICDEXT,SLST,SCTCEXT,TERMEXT,EXPTXT
+12 SET SLST=$GET(^TMP("GMPLIST",$JOB,IFN))
SET SCTCEXT=$PIECE(SLST,U,5)
+13 SET ICDEXT=$PIECE(SLST,U,4)
SET PICDEXT=$PIECE(ICDEXT,"/")
+14 SET TERMEXT=$PIECE(SLST,U,1)
+15 ;Compare problems with SNOMED CT concept codes & ICD code(s) only
+16 IF $LENGTH(SCTCEXT)
IF (GMPSRC="SNOMED CT")
IF ($GET(SCTCNEW)>0)
IF ($LENGTH(ICDNEW))
Begin DoDot:2
+17 ;if SCT concepts & primary + multiple ICD targets match => dup
+18 IF ICDEXT["/"
IF ICDNEW["/"
Begin DoDot:3
+19 NEW I,J,SICDEXT
SET J=0
FOR I=2:1:$LENGTH(ICDEXT,"/")
Begin DoDot:4
+20 SET J=J+1
SET SICDEXT(J)=$PIECE(ICDEXT,"/",I)
End DoDot:4
+21 NEW K,L,SICDNEW
SET L=0
FOR K=2:1:$LENGTH(ICDNEW,"/")
Begin DoDot:4
+22 SET L=L+1
SET SICDNEW(L)=$PIECE(ICDNEW,"/",K)
End DoDot:4
+23 NEW T
FOR T=1:1:L
Begin DoDot:4
+24 IF SCTCEXT=SCTCNEW
IF (PICDEXT=PICDNEW)
IF SICDEXT(T)=SICDNEW(T)
SET DA=IFN
QUIT
End DoDot:4
End DoDot:3
+25 ;if SCT concept codes match => dup
+26 IF '$TEST
IF ICDNEW=GMPOTHR!(PICDNEW=GMPOTHR)
Begin DoDot:3
+27 IF SCTCEXT=SCTCNEW
SET DA=IFN
QUIT
End DoDot:3
+28 ;if SCT concepts & primary ICD diagnosis match => dup
+29 IF '$TEST
IF SCTCEXT=SCTCNEW
IF (PICDEXT=PICDNEW)
SET DA=IFN
QUIT
End DoDot:2
+30 ;Compare legacy problems with ICD codes only
+31 IF '$TEST
IF $LENGTH(ICDEXT)
IF '$LENGTH(SCTCEXT)
IF (GMPSRC["ICD")
IF (+$GET(ICDNEW)>0)
Begin DoDot:2
+32 ;if Exprs match => dup
+33 IF +Y>1&(TERMEXT=+Y)
SET DA=IFN
QUIT
+34 ;if Text matches Expr from old => dup
+35 DO LOOK^LEXA("`"_TERMEXT)
+36 SET EXPTXT=$PIECE($GET(LEX("LIST",1)),U,2)
+37 SET TEXT=$$UP^XLFSTR($PIECE(TEXT," (ICD"))
+38 IF LEX>1&(TEXT=$$UP^XLFSTR($SELECT(EXPTXT["*":$PIECE(EXPTXT," *"),1:EXPTXT)))
SET DA=IFN
QUIT
+39 ;if prim ICD of new = prim ICD of old => dup
+40 IF PICDEXT'=GMPOTHR
IF (PICDNEW'=GMPOTHR)
IF (PICDEXT=PICDNEW)
SET DA=IFN
QUIT
End DoDot:2
End DoDot:1
if DA>0
QUIT
DUPLX QUIT DA
