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