- 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 Feb 18, 2025@23:56:18 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