GMPLBLD ; SLC/MKB -- Build Problem Selection Lists ;09/22/11 15:14
;;2.0;Problem List;**3,28,33,36**;Aug 25, 1994;Build 65
;
;This routine invokes IA #3991
;
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 IFN,SEQ,GRP,ITEM,CNT K ^TMP("GMPLIST",$J) S CNT=0
W !,"Searching for the list ..."
F IFN=0:0 S IFN=$O(^GMPL(125.1,"B",+GMPLSLST,IFN)) Q:IFN'>0 D
. S ITEM=$G(^GMPL(125.1,IFN,0)),SEQ=$P(ITEM,U,2),GRP=$P(ITEM,U,3)
. S ^TMP("GMPLIST",$J,IFN)=$P(ITEM,U,2,5),CNT=CNT+1 ; seq ^ group ^ subhdr ^ probs
. S (^TMP("GMPLIST",$J,"GRP",GRP),^TMP("GMPLIST",$J,"SEQ",SEQ))=IFN
S ^TMP("GMPLIST",$J,0)=CNT
Q
;
BUILD(LIST,MODE) ; Build ^TMP("GMPLST",$J,)
N SEQ,LCNT,NUM,HDR,GROUP,IFN,ITEM,PSEQ 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,SEQ)=0
F S SEQ=$O(^TMP("GMPLIST",$J,"SEQ",SEQ)) Q:SEQ'>0 D
. S IFN=^TMP("GMPLIST",$J,"SEQ",SEQ),LCNT=LCNT+1,NUM=NUM+1
. S GROUP=$P(^TMP("GMPLIST",$J,IFN),U,2),HDR=$P(^TMP("GMPLIST",$J,IFN),U,3)
. S:'$L(HDR) HDR="<no header>"
. I LCNT>1,+$P(^TMP("GMPLIST",$J,IFN),U,4),^TMP("GMPLST",$J,LCNT-1,0)'=" " S LCNT=LCNT+1,^TMP("GMPLST",$J,LCNT,0)=" "
. S ^TMP("GMPLST",$J,LCNT,0)=$S(MODE="I":$J("<"_SEQ_">",8),1:" ")_$J(NUM,4)_" "_HDR,^TMP("GMPLST",$J,"B",NUM)=IFN
. D CNTRL^VALM10(LCNT,9,5,IOINHI,IOINORM)
. Q:'+$P(^TMP("GMPLIST",$J,IFN),U,4)
. D CNTRL^VALM10(LCNT,14,$L(HDR),IOUON,IOUOFF)
. F PSEQ=0:0 S PSEQ=$O(^GMPL(125.12,"C",+GROUP,PSEQ)) Q:PSEQ'>0 D
.. S IFN=$O(^GMPL(125.12,"C",+GROUP,PSEQ,0)),LCNT=LCNT+1
.. S ITEM=$G(^GMPL(125.12,IFN,0)),^TMP("GMPLST",$J,LCNT,0)=" "_$P(ITEM,U,4)
.. I $L($P(ITEM,U,5)) D
... N GMI
... S ^TMP("GMPLST",$J,LCNT,0)=^TMP("GMPLST",$J,LCNT,0)_" ("_$P(ITEM,U,5)_")"
... F GMI=1:1:$L($P(ITEM,U,5),"/") D
.... I $$STATCHK^ICDAPIU($P($P(ITEM,U,5),"/",GMI),DT) Q ; code is active
.... S ^TMP("GMPLST",$J,LCNT,0)=^TMP("GMPLST",$J,LCNT,0)_" <INACTIVE 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
I $D(GMPLSAVE),$$CKSAVE^GMPLBLD2 D
. D SAVE^GMPLBLD2
. S ^GMPL(125,+GMPLSLST,0)=$P(GMPLSLST,U,2)_U_DT_U_$P(GMPLSLST,U,4)
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
F D Q:$D(GMPQUIT) W !
. S GROUP=$$GROUP^GMPLBLD2("") I GROUP="^" S GMPQUIT=1 Q
. 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 ICD-9 codes. "
.. W !,"These codes must be updated before adding the category to a selection 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)=SEQ_U_+GROUP_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
S VALMBCK="R",VALMSG=$$MSG^GMPLX
Q
;
EDIT ; Edit category contents
N GMPLIST,GMPLST,GMPLMODE,GMPLGRP,GMPLSAVE
D EN^VALM("GMPL SELECTION GROUP BUILD")
S GMPLMODE="E"
D GETLIST,BUILD("TMP(""GMPLIST"",$J)",GMPLMODE)
S VALMBCK="R",VALMSG=$$MSG^GMPLX
Q
;
REMOVE ; Remove group
N NUM,IFN,SEQ,GRP,DIR,X,Y S VALMBCK=""
S NUM=$$SEL1^GMPLBLD1 G:NUM="^" RMQ
S IFN=$G(^TMP("GMPLST",$J,"B",NUM)) G:+IFN'>0 RMQ
I "@"[$G(^TMP("GMPLIST",$J,IFN)) W $C(7),!!,"Category is not part of this 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
GMPLBLD ; SLC/MKB -- Build Problem Selection Lists ;09/22/11 15:14
+1 ;;2.0;Problem List;**3,28,33,36**;Aug 25, 1994;Build 65
+2 ;
+3 ;This routine invokes IA #3991
+4 ;
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 DO LENGTH
+7 QUIT
+8 ;
GETLIST ; Build ^TMP("GMPLIST",$J,#)
+1 NEW IFN,SEQ,GRP,ITEM,CNT
KILL ^TMP("GMPLIST",$JOB)
SET CNT=0
+2 WRITE !,"Searching for the list ..."
+3 FOR IFN=0:0
SET IFN=$ORDER(^GMPL(125.1,"B",+GMPLSLST,IFN))
IF IFN'>0
QUIT
Begin DoDot:1
+4 SET ITEM=$GET(^GMPL(125.1,IFN,0))
SET SEQ=$PIECE(ITEM,U,2)
SET GRP=$PIECE(ITEM,U,3)
+5 ; seq ^ group ^ subhdr ^ probs
SET ^TMP("GMPLIST",$JOB,IFN)=$PIECE(ITEM,U,2,5)
SET CNT=CNT+1
+6 SET (^TMP("GMPLIST",$JOB,"GRP",GRP),^TMP("GMPLIST",$JOB,"SEQ",SEQ))=IFN
End DoDot:1
+7 SET ^TMP("GMPLIST",$JOB,0)=CNT
+8 QUIT
+9 ;
BUILD(LIST,MODE) ; Build ^TMP("GMPLST",$J,)
+1 NEW SEQ,LCNT,NUM,HDR,GROUP,IFN,ITEM,PSEQ
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,SEQ)=0
+5 FOR
SET SEQ=$ORDER(^TMP("GMPLIST",$JOB,"SEQ",SEQ))
IF SEQ'>0
QUIT
Begin DoDot:1
+6 SET IFN=^TMP("GMPLIST",$JOB,"SEQ",SEQ)
SET LCNT=LCNT+1
SET NUM=NUM+1
+7 SET GROUP=$PIECE(^TMP("GMPLIST",$JOB,IFN),U,2)
SET HDR=$PIECE(^TMP("GMPLIST",$JOB,IFN),U,3)
+8 IF '$LENGTH(HDR)
SET HDR="<no header>"
+9 IF LCNT>1
IF +$PIECE(^TMP("GMPLIST",$JOB,IFN),U,4)
IF ^TMP("GMPLST",$JOB,LCNT-1,0)'=" "
SET LCNT=LCNT+1
SET ^TMP("GMPLST",$JOB,LCNT,0)=" "
+10 SET ^TMP("GMPLST",$JOB,LCNT,0)=$SELECT(MODE="I":$JUSTIFY("<"_SEQ_">",8),1:" ")_$JUSTIFY(NUM,4)_" "_HDR
SET ^TMP("GMPLST",$JOB,"B",NUM)=IFN
+11 DO CNTRL^VALM10(LCNT,9,5,IOINHI,IOINORM)
+12 IF '+$PIECE(^TMP("GMPLIST",$JOB,IFN),U,4)
QUIT
+13 DO CNTRL^VALM10(LCNT,14,$LENGTH(HDR),IOUON,IOUOFF)
+14 FOR PSEQ=0:0
SET PSEQ=$ORDER(^GMPL(125.12,"C",+GROUP,PSEQ))
IF PSEQ'>0
QUIT
Begin DoDot:2
+15 SET IFN=$ORDER(^GMPL(125.12,"C",+GROUP,PSEQ,0))
SET LCNT=LCNT+1
+16 SET ITEM=$GET(^GMPL(125.12,IFN,0))
SET ^TMP("GMPLST",$JOB,LCNT,0)=" "_$PIECE(ITEM,U,4)
+17 IF $LENGTH($PIECE(ITEM,U,5))
Begin DoDot:3
+18 NEW GMI
+19 SET ^TMP("GMPLST",$JOB,LCNT,0)=^TMP("GMPLST",$JOB,LCNT,0)_" ("_$PIECE(ITEM,U,5)_")"
+20 FOR GMI=1:1:$LENGTH($PIECE(ITEM,U,5),"/")
Begin DoDot:4
+21 ; code is active
IF $$STATCHK^ICDAPIU($PIECE($PIECE(ITEM,U,5),"/",GMI),DT)
QUIT
+22 SET ^TMP("GMPLST",$JOB,LCNT,0)=^TMP("GMPLST",$JOB,LCNT,0)_" <INACTIVE CODE>"
End DoDot:4
End DoDot:3
End DoDot:2
+23 SET LCNT=LCNT+1
SET ^TMP("GMPLST",$JOB,LCNT,0)=" "
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 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 IF $DATA(GMPLSAVE)
IF $$CKSAVE^GMPLBLD2
Begin DoDot:1
+2 DO SAVE^GMPLBLD2
+3 SET ^GMPL(125,+GMPLSLST,0)=$PIECE(GMPLSLST,U,2)_U_DT_U_$PIECE(GMPLSLST,U,4)
End DoDot:1
+4 LOCK -^GMPL(125,+GMPLSLST,0)
+5 KILL GMPLIST,GMPLST,GMPLMODE,GMPLSLST,GMPLSAVE,GMPREBLD,GMPQUIT,RT,TMPLST
+6 KILL ^TMP("GMPLIST",$JOB),^TMP("GMPLST",$JOB)
+7 QUIT
+8 ;
ADD ; Add group(s)
+1 NEW SEQ,GROUP,HDR,IFN,GMPQUIT,GMPREBLD
DO FULL^VALM1
+2 FOR
Begin DoDot:1
+3 SET GROUP=$$GROUP^GMPLBLD2("")
IF GROUP="^"
SET GMPQUIT=1
QUIT
+4 IF $DATA(^TMP("GMPLIST",$JOB,"GRP",+GROUP))
WRITE !?4,">>> This category is already part of this list!"
QUIT
+5 IF '$$VALGRP^GMPLBLD2(+GROUP)
Begin DoDot:2
+6 DO FULL^VALM1
+7 WRITE !!,$CHAR(7),"This category contains one or more problems with inactive ICD-9 codes. "
+8 WRITE !,"These codes must be updated before adding the category to a selection list."
+9 NEW DIR,DTOUT,DIRUT,DUOUT,X,Y
+10 SET DIR(0)="E"
DO ^DIR
+11 SET VALMBCK="R"
End DoDot:2
QUIT
+12 SET HDR=$$HDR^GMPLBLD1($PIECE(GROUP,U,2))
IF HDR="^"
SET GMPQUIT=1
QUIT
+13 SET RT="^TMP(""GMPLIST"",$J,""SEQ"","
SET SEQ=+$$LAST^GMPLBLD2(RT)+1
+14 SET SEQ=$$SEQ^GMPLBLD1(SEQ)
IF SEQ="^"
SET GMPQUIT=1
QUIT
+15 SET IFN=$$TMPIFN^GMPLBLD1
SET ^TMP("GMPLIST",$JOB,IFN)=SEQ_U_+GROUP_U_HDR_"^1"
+16 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 !
+17 IF $DATA(GMPREBLD)
SET VALMBCK="R"
SET GMPLSAVE=1
DO BUILD("^TMP(""GMPLIST"",$J)",GMPLMODE)
DO HDR
+18 SET VALMBCK="R"
SET VALMSG=$$MSG^GMPLX
+19 QUIT
+20 ;
EDIT ; Edit category contents
+1 NEW GMPLIST,GMPLST,GMPLMODE,GMPLGRP,GMPLSAVE
+2 DO EN^VALM("GMPL SELECTION GROUP BUILD")
+3 SET GMPLMODE="E"
+4 DO GETLIST
DO BUILD("TMP(""GMPLIST"",$J)",GMPLMODE)
+5 SET VALMBCK="R"
SET VALMSG=$$MSG^GMPLX
+6 QUIT
+7 ;
REMOVE ; Remove group
+1 NEW NUM,IFN,SEQ,GRP,DIR,X,Y
SET VALMBCK=""
+2 SET NUM=$$SEL1^GMPLBLD1
IF NUM="^"
GOTO RMQ
+3 SET IFN=$GET(^TMP("GMPLST",$JOB,"B",NUM))
IF +IFN'>0
GOTO RMQ
+4 IF "@"[$GET(^TMP("GMPLIST",$JOB,IFN))
WRITE $CHAR(7),!!,"Category is not part of this list!"
HANG 2
GOTO RMQ
+5 SET DIR("A")="Are you sure you want to remove '"_$PIECE(^TMP("GMPLIST",$JOB,IFN),U,3)_"'? "
+6 SET DIR("?")="Enter YES to delete this category from the current list; enter NO to exit."
+7 SET DIR(0)="YA"
SET DIR("B")="NO"
DO ^DIR
+8 IF 'Y
WRITE !?5,"< Nothing removed! >"
HANG 1
GOTO RMQ
+9 DO DELETE^GMPLBLD1(IFN)
SET VALMBCK="R"
SET GMPLSAVE=1
+10 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
