GMPLBLD ; SLC/MKB/TC -- Build Problem Selection Lists ;02/22/17 14:07
;;2.0;Problem List;**3,28,33,36,42,49**;Aug 25, 1994;Build 43
;
; External References:
; ICR 2056 $$GET1^DIQ
; ICR 4083 $$STATCHK^LEXSRC2
; ICR 5747 $$CODECS^ICDEX,$$STATCHK^ICDEX
; ICR 10026 ^DIR
; ICR 10103 $$DT^XLFDT,$$FMTE^XLFDT
; ICR 10116 FULL^VALM1
; ICR 10117 CNTRL^VALM10
; ICR 10118 EN^VALM
;
EN ; -- main entry point
D EN^VALM("GMPL SELECTION LIST BUILD")
Q
;
HDR ; -- header code
N NAME,NUM,DATE
S NUM=+^TMP("GMPLST",$J,0)_" categor"_$S(+^TMP("GMPLST",$J,0)'=1:"ies",1:"y")
S DATE="Last Modified: "_$S(+$P(GMPLSLST,U,3):$$FMTE^XLFDT($P(GMPLSLST,U,3)),1:"<new list>")
S VALMHDR(1)=DATE_$J(NUM,79-$L(DATE))
S NAME=$P(GMPLSLST,U,2),VALMHDR(2)=$J(NAME,$L(NAME)\2+41)
Q
;
INIT ; -- init variables and list array
S GMPLSLST=$$LIST^GMPLBLD2("L") I GMPLSLST="^" S VALMQUIT=1 Q
L +^GMPL(125,+GMPLSLST,0):1 I '$T D G INIT
. W $C(7),!!,"This list is currently being edited by another user!",!
S GMPLMODE="E",VALMSG=$$MSG^GMPLX
D GETLIST,BUILD("^TMP(""GMPLIST"",$J)",GMPLMODE)
;D LENGTH
Q
;
GETLIST ; Build ^TMP("GMPLIST",$J,#)
N GRP,ITEM,CNT,GMPLDA K ^TMP("GMPLIST",$J) S CNT=0,(GMPLDA,GMPLCSQ)=""
W !,"Searching for the list ..."
F S GMPLCSQ=$O(^GMPL(125,"AD",+GMPLSLST,GMPLCSQ)) Q:'GMPLCSQ D
. F S GMPLDA=$O(^GMPL(125,"AD",+GMPLSLST,GMPLCSQ,GMPLDA)) Q:GMPLDA'>0 D
. . S ITEM=$G(^GMPL(125,+GMPLSLST,1,GMPLDA,0)),GRP=$P(ITEM,U,1)
. . S ^TMP("GMPLIST",$J,GMPLDA)=$G(ITEM),CNT=CNT+1 ; group ^ seq ^ subhdr ^ probs
. . S (^TMP("GMPLIST",$J,"GRP",GRP),^TMP("GMPLIST",$J,"SEQ",GMPLCSQ))=GMPLDA
S ^TMP("GMPLIST",$J,0)=CNT
Q
;
BUILD(LIST,MODE) ; Build ^TMP("GMPLST",$J,)
N LCNT,NUM,HDR,GROUP,GMPSEQ,ITEM,IFN,PSEQ,GMPIFN,GMPLCSQ,GMPDT,GMPCLASS,GMPLSHDR,GMPLCOL D CLEAN^VALM10
S:'$D(^TMP("GMPLIST",$J,0)) ^TMP("GMPLIST",$J,0)=0
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
. S GMPIFN=^TMP("GMPLIST",$J,"SEQ",GMPSEQ),LCNT=LCNT+1,NUM=NUM+1
. S GROUP=$P(^TMP("GMPLIST",$J,GMPIFN),U,1),GMPLCSQ=$P(^TMP("GMPLIST",$J,GMPIFN),U,2)
. S HDR=$P(^TMP("GMPLIST",$J,GMPIFN),U,3),GMPCLASS=$$GET1^DIQ(125.11,""_GROUP_",",.03)
. S:'$L(HDR) HDR="<no header>"
. S HDR=HDR_" ("_GMPCLASS_")"
. I LCNT>1,+$P(^TMP("GMPLIST",$J,GMPIFN),U,4),^TMP("GMPLST",$J,LCNT-1,0)'=" " S LCNT=LCNT+1,^TMP("GMPLST",$J,LCNT,0)=" "
. S GMPLSHDR=$J(NUM,3)_" "_HDR
. S ^TMP("GMPLST",$J,LCNT,0)=$S(MODE="I":"<"_GMPLCSQ_">",1:" ")_GMPLSHDR,^TMP("GMPLST",$J,"B",NUM)=GMPIFN
. S GMPLCOL=(($L(^TMP("GMPLST",$J,LCNT,0)))-($L(GMPLSHDR)))+1
. D CNTRL^VALM10(LCNT,GMPLCOL,$L(GMPLSHDR),IOINHI,IOINORM)
. Q:'+$P(^TMP("GMPLIST",$J,GMPIFN),U,4)
. D CNTRL^VALM10(LCNT,8,$L(HDR),IOUON,IOUOFF)
. F PSEQ=0:0 S PSEQ=$O(^GMPL(125.11,"C",+GROUP,PSEQ)) Q:PSEQ'>0 D
.. N GMPCSYS,GMPLSCT,GMPLICD,GMPSCTC,GMPICD,GMPDTXT S (GMPLSCT,GMPLICD)=0
.. S IFN=$O(^GMPL(125.11,"C",+GROUP,PSEQ,0)),LCNT=LCNT+1
.. S ITEM=$G(^GMPL(125.11,+GROUP,1,IFN,0)),GMPDTXT=$P(ITEM,U,3)
.. S GMPSCTC=$P(ITEM,U,5),GMPICD=$P(ITEM,U,4)
.. S ^TMP("GMPLST",$J,LCNT,0)=" "_GMPDTXT
.. I $L(GMPSCTC) D
... I $$STATCHK^LEXSRC2(GMPSCTC,GMPDT,"","SCT") Q
... S GMPLSCT=1
.. I $L(GMPICD) D
... N GMI,GMPCSPTR,GMPCSREC,GMPCSNME
... S GMPCSREC=$$CODECS^ICDEX($P(GMPICD,"/"),80,GMPDT),GMPCSPTR=$P(GMPCSREC,U),GMPCSNME=$P(GMPCSREC,U,2)
... S ^TMP("GMPLST",$J,LCNT,0)=^TMP("GMPLST",$J,LCNT,0)_" ("_GMPCSNME_" "_GMPICD_")"
... F GMI=1:1:$L(GMPICD,"/") D
.... I $$STATCHK^ICDEX($P(GMPICD,"/",GMI),GMPDT,GMPCSPTR) Q ; code is active
.... S GMPLICD=1
.. S GMPCSYS=$S(GMPLSCT:"SCT",GMPLICD:"ICD",(GMPLSCT&GMPLICD):"SCT/ICD",1:"")
.. S:GMPCSYS'="" ^TMP("GMPLST",$J,LCNT,0)=^TMP("GMPLST",$J,LCNT,0)_" <INACTIVE "_GMPCSYS_" CODE>"
. S LCNT=LCNT+1,^TMP("GMPLST",$J,LCNT,0)=" "
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 to update this selection list."
W !?4,"New categories may be added to this list, or an existing one"
W !?4,"removed; Edit Category will allow you to change the contents of"
W !?4,"a category, or create a new one that may be added to this list."
W !?4,"You may also change how each category appears in this list,"
W !?4,"view each category's sequence number to facilitate resequencing,"
W !?4,"assign this list to a clinic or user(s), or edit a different list."
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,+GMPLSLST,0)=$P(GMPLSLST,U,2)_U_GMPDT_U_$P(GMPLSLST,U,4)_U_$P(GMPLSLST,U,5)
L -^GMPL(125,+GMPLSLST,0)
K GMPLIST,GMPLST,GMPLMODE,GMPLSLST,GMPLSAVE,GMPREBLD,GMPQUIT,RT,TMPLST
K ^TMP("GMPLIST",$J),^TMP("GMPLST",$J)
Q
;
ADD ; Add group(s)
N SEQ,GROUP,HDR,IFN,GMPQUIT,GMPREBLD D FULL^VALM1
I $P($G(GMPLSLST),U,5)="N" W !!,"Cannot make edits to a National list." H 2 G ADQ
F D Q:$D(GMPQUIT) W !
. S GROUP=$$GROUP^GMPLBLD2("") I GROUP="^" S GMPQUIT=1 Q
. I $P(GROUP,U,4)="N" D Q
. . W !!,"Cannot add a National category to a list. Please use the Copy to New Category"
. . W !,"menu action under the Enter/Edit Category menu to copy into a local category."
. . H 2 G ADQ
. I $D(^TMP("GMPLIST",$J,"GRP",+GROUP)) W !?4,">>> This category is already part of this list!" Q
. I '$$VALGRP^GMPLBLD2(+GROUP) D Q
. . D FULL^VALM1
. . W !!,$C(7),"This category contains one or more problems with inactive SNOMED and/or ICD"
. . W !,"codes. These codes must be updated before adding the category to a selection"
. . W !,"list."
. . N DIR,DTOUT,DIRUT,DUOUT,X,Y
. . S DIR(0)="E" D ^DIR
. . S VALMBCK="R"
. S HDR=$$HDR^GMPLBLD1($P(GROUP,U,2)) I HDR="^" S GMPQUIT=1 Q
. S RT="^TMP(""GMPLIST"",$J,""SEQ"",",SEQ=+$$LAST^GMPLBLD2(RT)+1
. S SEQ=$$SEQ^GMPLBLD1(SEQ) I SEQ="^" S GMPQUIT=1 Q
. S IFN=$$TMPIFN^GMPLBLD1,^TMP("GMPLIST",$J,IFN)=+GROUP_U_SEQ_U_HDR_"^1"
. S (^TMP("GMPLIST",$J,"GRP",+GROUP),^TMP("GMPLIST",$J,"SEQ",SEQ))=IFN,^TMP("GMPLIST",$J,0)=^TMP("GMPLIST",$J,0)+1,GMPREBLD=1
I $D(GMPREBLD) S VALMBCK="R",GMPLSAVE=1 D BUILD("^TMP(""GMPLIST"",$J)",GMPLMODE),HDR
ADQ S VALMBCK="R",VALMSG=$$MSG^GMPLX
Q
;
EDIT ; Edit category contents
N GMPLIST,GMPLST,GMPLMODE,GMPLGRP,GMPLSAVE
I $P($G(GMPLSLST),U,5)="N" W !!,"Cannot make edits to a National list." H 2 G EDQ
D EN^VALM("GMPL SELECTION GROUP BUILD")
S GMPLMODE="E"
D GETLIST,BUILD("TMP(""GMPLIST"",$J)",GMPLMODE)
EDQ S VALMBCK="R",VALMSG=$$MSG^GMPLX
Q
;
REMOVE ; Remove group
N NUM,IFN,SEQ,GRP,DIR,X,Y,GMPLCIEN S VALMBCK=""
I $P($G(GMPLSLST),U,5)="N" W !!,"Cannot make edits to a National list." H 2 G RMQ
S NUM=$$SEL1^GMPLBLD1 G:NUM="^" RMQ
S IFN=$G(^TMP("GMPLST",$J,"B",NUM)) G:+IFN'>0 RMQ
S GMPLCIEN=$P($G(^TMP("GMPLIST",$J,IFN)),U,1)
I "@"[$G(^TMP("GMPLIST",$J,IFN)) W $C(7),!!,"Category is not part of this list!" H 2 G RMQ
I $P(^GMPL(125.11,GMPLCIEN,0),U,3)="N",($P($G(GMPLSLST),U,5)="N") W $C(7),!!,"Category may not be removed from this National list!" H 2 G RMQ
S DIR("A")="Are you sure you want to remove '"_$P(^TMP("GMPLIST",$J,IFN),U,3)_"'? "
S DIR("?")="Enter YES to delete this category from the current list; enter NO to exit."
S DIR(0)="YA",DIR("B")="NO" D ^DIR
I 'Y 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
;
LENGTH ;SHORTEN THE ICD9'S DESCRIPTION TO FIT SCREEN
S LLCNT=0
F S LLCNT=$O(^TMP("GMPLST",$J,LLCNT)) Q:LLCNT="" Q:LLCNT'?1N.N D
.; I '$D(^TMP("GMPLST",$J,LLCNT,O)) Q
. S ICD9VAR=^TMP("GMPLST",$J,LLCNT,0) I $L(ICD9VAR)>50 D
.. S ICD9VAR=$P(ICD9VAR,"(",1)
.. S ICD9VAR=$E(ICD9VAR,1,50)_" ("_$P(^TMP("GMPLST",$J,LLCNT,0),"(",2)
.. S ^TMP("GMPLST",$J,LLCNT,0)=ICD9VAR
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMPLBLD 8187 printed Dec 13, 2024@02:29:45 Page 2
GMPLBLD ; SLC/MKB/TC -- Build Problem Selection Lists ;02/22/17 14:07
+1 ;;2.0;Problem List;**3,28,33,36,42,49**;Aug 25, 1994;Build 43
+2 ;
+3 ; External References:
+4 ; ICR 2056 $$GET1^DIQ
+5 ; ICR 4083 $$STATCHK^LEXSRC2
+6 ; ICR 5747 $$CODECS^ICDEX,$$STATCHK^ICDEX
+7 ; ICR 10026 ^DIR
+8 ; ICR 10103 $$DT^XLFDT,$$FMTE^XLFDT
+9 ; ICR 10116 FULL^VALM1
+10 ; ICR 10117 CNTRL^VALM10
+11 ; ICR 10118 EN^VALM
+12 ;
EN ; -- main entry point
+1 DO EN^VALM("GMPL SELECTION LIST BUILD")
+2 QUIT
+3 ;
HDR ; -- header code
+1 NEW NAME,NUM,DATE
+2 SET NUM=+^TMP("GMPLST",$JOB,0)_" categor"_$SELECT(+^TMP("GMPLST",$JOB,0)'=1:"ies",1:"y")
+3 SET DATE="Last Modified: "_$SELECT(+$PIECE(GMPLSLST,U,3):$$FMTE^XLFDT($PIECE(GMPLSLST,U,3)),1:"<new list>")
+4 SET VALMHDR(1)=DATE_$JUSTIFY(NUM,79-$LENGTH(DATE))
+5 SET NAME=$PIECE(GMPLSLST,U,2)
SET VALMHDR(2)=$JUSTIFY(NAME,$LENGTH(NAME)\2+41)
+6 QUIT
+7 ;
INIT ; -- init variables and list array
+1 SET GMPLSLST=$$LIST^GMPLBLD2("L")
IF GMPLSLST="^"
SET VALMQUIT=1
QUIT
+2 LOCK +^GMPL(125,+GMPLSLST,0):1
IF '$TEST
Begin DoDot:1
+3 WRITE $CHAR(7),!!,"This list 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 ;D LENGTH
+7 QUIT
+8 ;
GETLIST ; Build ^TMP("GMPLIST",$J,#)
+1 NEW GRP,ITEM,CNT,GMPLDA
KILL ^TMP("GMPLIST",$JOB)
SET CNT=0
SET (GMPLDA,GMPLCSQ)=""
+2 WRITE !,"Searching for the list ..."
+3 FOR
SET GMPLCSQ=$ORDER(^GMPL(125,"AD",+GMPLSLST,GMPLCSQ))
if 'GMPLCSQ
QUIT
Begin DoDot:1
+4 FOR
SET GMPLDA=$ORDER(^GMPL(125,"AD",+GMPLSLST,GMPLCSQ,GMPLDA))
if GMPLDA'>0
QUIT
Begin DoDot:2
+5 SET ITEM=$GET(^GMPL(125,+GMPLSLST,1,GMPLDA,0))
SET GRP=$PIECE(ITEM,U,1)
+6 ; group ^ seq ^ subhdr ^ probs
SET ^TMP("GMPLIST",$JOB,GMPLDA)=$GET(ITEM)
SET CNT=CNT+1
+7 SET (^TMP("GMPLIST",$JOB,"GRP",GRP),^TMP("GMPLIST",$JOB,"SEQ",GMPLCSQ))=GMPLDA
End DoDot:2
End DoDot:1
+8 SET ^TMP("GMPLIST",$JOB,0)=CNT
+9 QUIT
+10 ;
BUILD(LIST,MODE) ; Build ^TMP("GMPLST",$J,)
+1 NEW LCNT,NUM,HDR,GROUP,GMPSEQ,ITEM,IFN,PSEQ,GMPIFN,GMPLCSQ,GMPDT,GMPCLASS,GMPLSHDR,GMPLCOL
DO CLEAN^VALM10
+2 if '$DATA(^TMP("GMPLIST",$JOB,0))
SET ^TMP("GMPLIST",$JOB,0)=0
+3 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
+4 SET (LCNT,NUM,GMPSEQ)=0
SET GMPDT=$$DT^XLFDT
+5 FOR
SET GMPSEQ=$ORDER(^TMP("GMPLIST",$JOB,"SEQ",GMPSEQ))
if GMPSEQ'>0
QUIT
Begin DoDot:1
+6 SET GMPIFN=^TMP("GMPLIST",$JOB,"SEQ",GMPSEQ)
SET LCNT=LCNT+1
SET NUM=NUM+1
+7 SET GROUP=$PIECE(^TMP("GMPLIST",$JOB,GMPIFN),U,1)
SET GMPLCSQ=$PIECE(^TMP("GMPLIST",$JOB,GMPIFN),U,2)
+8 SET HDR=$PIECE(^TMP("GMPLIST",$JOB,GMPIFN),U,3)
SET GMPCLASS=$$GET1^DIQ(125.11,""_GROUP_",",.03)
+9 if '$LENGTH(HDR)
SET HDR="<no header>"
+10 SET HDR=HDR_" ("_GMPCLASS_")"
+11 IF LCNT>1
IF +$PIECE(^TMP("GMPLIST",$JOB,GMPIFN),U,4)
IF ^TMP("GMPLST",$JOB,LCNT-1,0)'=" "
SET LCNT=LCNT+1
SET ^TMP("GMPLST",$JOB,LCNT,0)=" "
+12 SET GMPLSHDR=$JUSTIFY(NUM,3)_" "_HDR
+13 SET ^TMP("GMPLST",$JOB,LCNT,0)=$SELECT(MODE="I":"<"_GMPLCSQ_">",1:" ")_GMPLSHDR
SET ^TMP("GMPLST",$JOB,"B",NUM)=GMPIFN
+14 SET GMPLCOL=(($LENGTH(^TMP("GMPLST",$JOB,LCNT,0)))-($LENGTH(GMPLSHDR)))+1
+15 DO CNTRL^VALM10(LCNT,GMPLCOL,$LENGTH(GMPLSHDR),IOINHI,IOINORM)
+16 if '+$PIECE(^TMP("GMPLIST",$JOB,GMPIFN),U,4)
QUIT
+17 DO CNTRL^VALM10(LCNT,8,$LENGTH(HDR),IOUON,IOUOFF)
+18 FOR PSEQ=0:0
SET PSEQ=$ORDER(^GMPL(125.11,"C",+GROUP,PSEQ))
if PSEQ'>0
QUIT
Begin DoDot:2
+19 NEW GMPCSYS,GMPLSCT,GMPLICD,GMPSCTC,GMPICD,GMPDTXT
SET (GMPLSCT,GMPLICD)=0
+20 SET IFN=$ORDER(^GMPL(125.11,"C",+GROUP,PSEQ,0))
SET LCNT=LCNT+1
+21 SET ITEM=$GET(^GMPL(125.11,+GROUP,1,IFN,0))
SET GMPDTXT=$PIECE(ITEM,U,3)
+22 SET GMPSCTC=$PIECE(ITEM,U,5)
SET GMPICD=$PIECE(ITEM,U,4)
+23 SET ^TMP("GMPLST",$JOB,LCNT,0)=" "_GMPDTXT
+24 IF $LENGTH(GMPSCTC)
Begin DoDot:3
+25 IF $$STATCHK^LEXSRC2(GMPSCTC,GMPDT,"","SCT")
QUIT
+26 SET GMPLSCT=1
End DoDot:3
+27 IF $LENGTH(GMPICD)
Begin DoDot:3
+28 NEW GMI,GMPCSPTR,GMPCSREC,GMPCSNME
+29 SET GMPCSREC=$$CODECS^ICDEX($PIECE(GMPICD,"/"),80,GMPDT)
SET GMPCSPTR=$PIECE(GMPCSREC,U)
SET GMPCSNME=$PIECE(GMPCSREC,U,2)
+30 SET ^TMP("GMPLST",$JOB,LCNT,0)=^TMP("GMPLST",$JOB,LCNT,0)_" ("_GMPCSNME_" "_GMPICD_")"
+31 FOR GMI=1:1:$LENGTH(GMPICD,"/")
Begin DoDot:4
+32 ; code is active
IF $$STATCHK^ICDEX($PIECE(GMPICD,"/",GMI),GMPDT,GMPCSPTR)
QUIT
+33 SET GMPLICD=1
End DoDot:4
End DoDot:3
+34 SET GMPCSYS=$SELECT(GMPLSCT:"SCT",GMPLICD:"ICD",(GMPLSCT&GMPLICD):"SCT/ICD",1:"")
+35 if GMPCSYS'=""
SET ^TMP("GMPLST",$JOB,LCNT,0)=^TMP("GMPLST",$JOB,LCNT,0)_" <INACTIVE "_GMPCSYS_" CODE>"
End DoDot:2
+36 SET LCNT=LCNT+1
SET ^TMP("GMPLST",$JOB,LCNT,0)=" "
End DoDot:1
+37 SET ^TMP("GMPLST",$JOB,0)=NUM_U_LCNT
SET VALMCNT=LCNT
+38 QUIT
+39 ;
HELP ; -- help code
+1 NEW X
+2 WRITE !!?4,"You may take a variety of actions to update this selection list."
+3 WRITE !?4,"New categories may be added to this list, or an existing one"
+4 WRITE !?4,"removed; Edit Category will allow you to change the contents of"
+5 WRITE !?4,"a category, or create a new one that may be added to this list."
+6 WRITE !?4,"You may also change how each category appears in this list,"
+7 WRITE !?4,"view each category's sequence number to facilitate resequencing,"
+8 WRITE !?4,"assign this list to a clinic or user(s), or edit a different list."
+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,+GMPLSLST,0)=$PIECE(GMPLSLST,U,2)_U_GMPDT_U_$PIECE(GMPLSLST,U,4)_U_$PIECE(GMPLSLST,U,5)
End DoDot:1
+6 LOCK -^GMPL(125,+GMPLSLST,0)
+7 KILL GMPLIST,GMPLST,GMPLMODE,GMPLSLST,GMPLSAVE,GMPREBLD,GMPQUIT,RT,TMPLST
+8 KILL ^TMP("GMPLIST",$JOB),^TMP("GMPLST",$JOB)
+9 QUIT
+10 ;
ADD ; Add group(s)
+1 NEW SEQ,GROUP,HDR,IFN,GMPQUIT,GMPREBLD
DO FULL^VALM1
+2 IF $PIECE($GET(GMPLSLST),U,5)="N"
WRITE !!,"Cannot make edits to a National list."
HANG 2
GOTO ADQ
+3 FOR
Begin DoDot:1
+4 SET GROUP=$$GROUP^GMPLBLD2("")
IF GROUP="^"
SET GMPQUIT=1
QUIT
+5 IF $PIECE(GROUP,U,4)="N"
Begin DoDot:2
+6 WRITE !!,"Cannot add a National category to a list. Please use the Copy to New Category"
+7 WRITE !,"menu action under the Enter/Edit Category menu to copy into a local category."
+8 HANG 2
GOTO ADQ
End DoDot:2
QUIT
+9 IF $DATA(^TMP("GMPLIST",$JOB,"GRP",+GROUP))
WRITE !?4,">>> This category is already part of this list!"
QUIT
+10 IF '$$VALGRP^GMPLBLD2(+GROUP)
Begin DoDot:2
+11 DO FULL^VALM1
+12 WRITE !!,$CHAR(7),"This category contains one or more problems with inactive SNOMED and/or ICD"
+13 WRITE !,"codes. These codes must be updated before adding the category to a selection"
+14 WRITE !,"list."
+15 NEW DIR,DTOUT,DIRUT,DUOUT,X,Y
+16 SET DIR(0)="E"
DO ^DIR
+17 SET VALMBCK="R"
End DoDot:2
QUIT
+18 SET HDR=$$HDR^GMPLBLD1($PIECE(GROUP,U,2))
IF HDR="^"
SET GMPQUIT=1
QUIT
+19 SET RT="^TMP(""GMPLIST"",$J,""SEQ"","
SET SEQ=+$$LAST^GMPLBLD2(RT)+1
+20 SET SEQ=$$SEQ^GMPLBLD1(SEQ)
IF SEQ="^"
SET GMPQUIT=1
QUIT
+21 SET IFN=$$TMPIFN^GMPLBLD1
SET ^TMP("GMPLIST",$JOB,IFN)=+GROUP_U_SEQ_U_HDR_"^1"
+22 SET (^TMP("GMPLIST",$JOB,"GRP",+GROUP),^TMP("GMPLIST",$JOB,"SEQ",SEQ))=IFN
SET ^TMP("GMPLIST",$JOB,0)=^TMP("GMPLIST",$JOB,0)+1
SET GMPREBLD=1
End DoDot:1
if $DATA(GMPQUIT)
QUIT
WRITE !
+23 IF $DATA(GMPREBLD)
SET VALMBCK="R"
SET GMPLSAVE=1
DO BUILD("^TMP(""GMPLIST"",$J)",GMPLMODE)
DO HDR
ADQ SET VALMBCK="R"
SET VALMSG=$$MSG^GMPLX
+1 QUIT
+2 ;
EDIT ; Edit category contents
+1 NEW GMPLIST,GMPLST,GMPLMODE,GMPLGRP,GMPLSAVE
+2 IF $PIECE($GET(GMPLSLST),U,5)="N"
WRITE !!,"Cannot make edits to a National list."
HANG 2
GOTO EDQ
+3 DO EN^VALM("GMPL SELECTION GROUP BUILD")
+4 SET GMPLMODE="E"
+5 DO GETLIST
DO BUILD("TMP(""GMPLIST"",$J)",GMPLMODE)
EDQ SET VALMBCK="R"
SET VALMSG=$$MSG^GMPLX
+1 QUIT
+2 ;
REMOVE ; Remove group
+1 NEW NUM,IFN,SEQ,GRP,DIR,X,Y,GMPLCIEN
SET VALMBCK=""
+2 IF $PIECE($GET(GMPLSLST),U,5)="N"
WRITE !!,"Cannot make edits to a National list."
HANG 2
GOTO RMQ
+3 SET NUM=$$SEL1^GMPLBLD1
if NUM="^"
GOTO RMQ
+4 SET IFN=$GET(^TMP("GMPLST",$JOB,"B",NUM))
if +IFN'>0
GOTO RMQ
+5 SET GMPLCIEN=$PIECE($GET(^TMP("GMPLIST",$JOB,IFN)),U,1)
+6 IF "@"[$GET(^TMP("GMPLIST",$JOB,IFN))
WRITE $CHAR(7),!!,"Category is not part of this list!"
HANG 2
GOTO RMQ
+7 IF $PIECE(^GMPL(125.11,GMPLCIEN,0),U,3)="N"
IF ($PIECE($GET(GMPLSLST),U,5)="N")
WRITE $CHAR(7),!!,"Category may not be removed from this National list!"
HANG 2
GOTO RMQ
+8 SET DIR("A")="Are you sure you want to remove '"_$PIECE(^TMP("GMPLIST",$JOB,IFN),U,3)_"'? "
+9 SET DIR("?")="Enter YES to delete this category from the current list; enter NO to exit."
+10 SET DIR(0)="YA"
SET DIR("B")="NO"
DO ^DIR
+11 IF 'Y
WRITE !?5,"< Nothing removed! >"
HANG 1
GOTO RMQ
+12 DO DELETE^GMPLBLD1(IFN)
SET VALMBCK="R"
SET GMPLSAVE=1
+13 DO BUILD("^TMP(""GMPLIST"",$J)",GMPLMODE)
DO HDR
RMQ if 'VALMCC
SET VALMBCK="R"
SET VALMSG=$$MSG^GMPLX
+1 QUIT
+2 ;
LENGTH ;SHORTEN THE ICD9'S DESCRIPTION TO FIT SCREEN
+1 SET LLCNT=0
+2 FOR
SET LLCNT=$ORDER(^TMP("GMPLST",$JOB,LLCNT))
if LLCNT=""
QUIT
if LLCNT'?1N.N
QUIT
Begin DoDot:1
+3 ; I '$D(^TMP("GMPLST",$J,LLCNT,O)) Q
+4 SET ICD9VAR=^TMP("GMPLST",$JOB,LLCNT,0)
IF $LENGTH(ICD9VAR)>50
Begin DoDot:2
+5 SET ICD9VAR=$PIECE(ICD9VAR,"(",1)
+6 SET ICD9VAR=$EXTRACT(ICD9VAR,1,50)_" ("_$PIECE(^TMP("GMPLST",$JOB,LLCNT,0),"(",2)
+7 SET ^TMP("GMPLST",$JOB,LLCNT,0)=ICD9VAR
End DoDot:2
End DoDot:1
+8 QUIT
