Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: GMPLBLDC

GMPLBLDC.m

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