GMPLBLDC ; SLC/MKB -- Build Problem Selection Categories ;09/22/11 14:31
;;2.0;Problem List;**3,7,28,36**;Aug 25, 1994;Build 65
;
; This routine invokes IA #3991
;
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 SEQ,IFN,ITEM,PROB,CNT K ^TMP("GMPLIST",$J) S CNT=0
W !,"Searching for the problems ..."
F IFN=0:0 S IFN=$O(^GMPL(125.12,"B",+GMPLGRP,IFN)) Q:IFN'>0 D
. S ITEM=$G(^GMPL(125.12,IFN,0)),SEQ=$P(ITEM,U,2),PROB=$P(ITEM,U,3)
. S ^TMP("GMPLIST",$J,IFN)=$P(ITEM,U,2,7),CNT=CNT+1 ; seq ^ prob ^ text ^ code ^ snomed ct concept ^ snomed ct designation
. S (^TMP("GMPLIST",$J,"PROB",PROB),^TMP("GMPLIST",$J,"SEQ",SEQ))=IFN ; Xrefs
S ^TMP("GMPLIST",$J,0)=CNT
Q
;
BUILD(LIST,MODE) ; Build ^TMP("GMPLST",$J,) of current items in LIST for display
N SEQ,LCNT,NUM,PROB,TEXT,IFN,ITEM,CODE 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,SEQ)=0
F S SEQ=$O(^TMP("GMPLIST",$J,"SEQ",SEQ)) Q:SEQ'>0 D
. N GMI
. S IFN=^TMP("GMPLIST",$J,"SEQ",SEQ),LCNT=LCNT+1,NUM=NUM+1
. S PROB=$P(^TMP("GMPLIST",$J,IFN),U,2),TEXT=$P(^TMP("GMPLIST",$J,IFN),U,3),CODE=$P(^TMP("GMPLIST",$J,IFN),U,4)
. S ^TMP("GMPLST",$J,LCNT,0)=$S(MODE="I":$J("<"_SEQ_">",8),1:" ")_$J(NUM,4)_" "_TEXT
. I $L(CODE) D
.. S ^TMP("GMPLST",$J,LCNT,0)=^TMP("GMPLST",$J,LCNT,0)_" ("_CODE_")"
.. F GMI=1:1:$L(CODE,"/") D
... I $$STATCHK^ICDAPIU($P(CODE,"/",GMI),DT) Q ; OK - code is active
... S ^TMP("GMPLST",$J,LCNT,0)=^TMP("GMPLST",$J,LCNT,0)_" <INACTIVE CODE>"
. D CNTRL^VALM10(LCNT,9,5,IOINHI,IOINORM)
. S ^TMP("GMPLST",$J,"B",NUM)=IFN
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
I $D(GMPLSAVE),$$CKSAVE^GMPLBLD2 D
. D SAVE^GMPLBLD2
. S ^GMPL(125.11,+GMPLGRP,0)=$P(GMPLGRP,U,2)_U_DT
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 S VALMBCK="" D FULL^VALM1
S GMPVOCAB="" ; $$VOCAB^GMPLX1 Q:GMPVOCAB="^"
F D Q:$D(GMPQUIT) W !!
. N X,Y,SEQ,CODE,IFN,SCTS,SCTT,SCTC,SCTD
. S (X,Y,SCTS,SCTT,SCTC,SCTD)="" D SEARCH^GMPLX(.X,.Y,"PROBLEM: ","1",GMPVOCAB)
. I +Y'>0 S GMPQUIT=1 Q
. I X["(SCT" D
. . S SCTS=X
. . S SCTT=$P(SCTS," (SCT ")
. . S SCTC=$P($P(SCTS,"SCT ",2),")")
. . S SCTD=$$GETDES^LEXTRAN1("SCT",SCTT)
. . S SCTD=$S(+SCTD=1:$P(SCTD,U,2),1:"")
. S X=$$TEXT^GMPLBLD1(X) I X="^" S GMPQUIT=1 Q
. S CODE=$$CODE^GMPLBLD1($G(SCTC),$G(Y(1))) I CODE']"" S GMPQUIT=1 Q
. S RT1="^TMP(""GMPLIST"",$J,""SEQ"",",SEQ=+$$LAST^GMPLBLD2(RT1)+1 ; dflt = next #
. S SEQ=$$SEQ^GMPLBLD1(SEQ) I SEQ="^" S GMPQUIT=1 Q
. S IFN=$$TMPIFN^GMPLBLD1,^TMP("GMPLIST",$J,0)=^TMP("GMPLIST",$J,0)+1
. S ^TMP("GMPLIST",$J,IFN)=SEQ_U_+Y_U_X_U_CODE_U_SCTC_U_SCTD ; seq ^ # ^ text ^ code
. S (^TMP("GMPLIST",$J,"PROB",+Y),^TMP("GMPLIST",$J,"SEQ",SEQ))=IFN,GMPREBLD=1
I $D(GMPREBLD) S VALMBCK="R",GMPLSAVE=1 D BUILD("^TMP(""GMPLIST"",$J)",GMPLMODE),HDR
S VALMBCK="R" S VALMSG=$$MSG^GMPLX
Q
;
REMOVE ; Remove problem from group
N NUM,IFN S VALMBCK=""
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
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,2)>1 " = "_$G(^LEX(757.01,+$P(PROBLEM,U,2),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
GMPLBLDC ; SLC/MKB -- Build Problem Selection Categories ;09/22/11 14:31
+1 ;;2.0;Problem List;**3,7,28,36**;Aug 25, 1994;Build 65
+2 ;
+3 ; This routine invokes IA #3991
+4 ;
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 SEQ,IFN,ITEM,PROB,CNT
KILL ^TMP("GMPLIST",$JOB)
SET CNT=0
+2 WRITE !,"Searching for the problems ..."
+3 FOR IFN=0:0
SET IFN=$ORDER(^GMPL(125.12,"B",+GMPLGRP,IFN))
IF IFN'>0
QUIT
Begin DoDot:1
+4 SET ITEM=$GET(^GMPL(125.12,IFN,0))
SET SEQ=$PIECE(ITEM,U,2)
SET PROB=$PIECE(ITEM,U,3)
+5 ; seq ^ prob ^ text ^ code ^ snomed ct concept ^ snomed ct designation
SET ^TMP("GMPLIST",$JOB,IFN)=$PIECE(ITEM,U,2,7)
SET CNT=CNT+1
+6 ; Xrefs
SET (^TMP("GMPLIST",$JOB,"PROB",PROB),^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,) of current items in LIST for display
+1 NEW SEQ,LCNT,NUM,PROB,TEXT,IFN,ITEM,CODE
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,SEQ)=0
+4 FOR
SET SEQ=$ORDER(^TMP("GMPLIST",$JOB,"SEQ",SEQ))
IF SEQ'>0
QUIT
Begin DoDot:1
+5 NEW GMI
+6 SET IFN=^TMP("GMPLIST",$JOB,"SEQ",SEQ)
SET LCNT=LCNT+1
SET NUM=NUM+1
+7 SET PROB=$PIECE(^TMP("GMPLIST",$JOB,IFN),U,2)
SET TEXT=$PIECE(^TMP("GMPLIST",$JOB,IFN),U,3)
SET CODE=$PIECE(^TMP("GMPLIST",$JOB,IFN),U,4)
+8 SET ^TMP("GMPLST",$JOB,LCNT,0)=$SELECT(MODE="I":$JUSTIFY("<"_SEQ_">",8),1:" ")_$JUSTIFY(NUM,4)_" "_TEXT
+9 IF $LENGTH(CODE)
Begin DoDot:2
+10 SET ^TMP("GMPLST",$JOB,LCNT,0)=^TMP("GMPLST",$JOB,LCNT,0)_" ("_CODE_")"
+11 FOR GMI=1:1:$LENGTH(CODE,"/")
Begin DoDot:3
+12 ; OK - code is active
IF $$STATCHK^ICDAPIU($PIECE(CODE,"/",GMI),DT)
QUIT
+13 SET ^TMP("GMPLST",$JOB,LCNT,0)=^TMP("GMPLST",$JOB,LCNT,0)_" <INACTIVE CODE>"
End DoDot:3
End DoDot:2
+14 DO CNTRL^VALM10(LCNT,9,5,IOINHI,IOINORM)
+15 SET ^TMP("GMPLST",$JOB,"B",NUM)=IFN
End DoDot:1
+16 SET ^TMP("GMPLST",$JOB,0)=NUM_U_LCNT
SET VALMCNT=LCNT
+17 QUIT
+18 ;
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 IF $DATA(GMPLSAVE)
IF $$CKSAVE^GMPLBLD2
Begin DoDot:1
+2 DO SAVE^GMPLBLD2
+3 SET ^GMPL(125.11,+GMPLGRP,0)=$PIECE(GMPLGRP,U,2)_U_DT
End DoDot:1
+4 LOCK -^GMPL(125.11,+GMPLGRP,0)
+5 KILL GMPLIST,GMPLST,GMPLMODE,GMPLGRP,GMPLSAVE,GMPREBLD,GMPQUIT,RT1,TMPITEM
+6 KILL VALMBCK,VALMCNT,VALMSG,VALMHDR
+7 KILL ^TMP("GMPLIST",$JOB),^TMP("GMPLST",$JOB)
+8 QUIT
+9 ;
ADD ; Add new problem(s)
+1 NEW GMPVOCAB,GMPQUIT,GMPREBLD
SET VALMBCK=""
DO FULL^VALM1
+2 ; $$VOCAB^GMPLX1 Q:GMPVOCAB="^"
SET GMPVOCAB=""
+3 FOR
Begin DoDot:1
+4 NEW X,Y,SEQ,CODE,IFN,SCTS,SCTT,SCTC,SCTD
+5 SET (X,Y,SCTS,SCTT,SCTC,SCTD)=""
DO SEARCH^GMPLX(.X,.Y,"PROBLEM: ","1",GMPVOCAB)
+6 IF +Y'>0
SET GMPQUIT=1
QUIT
+7 IF X["(SCT"
Begin DoDot:2
+8 SET SCTS=X
+9 SET SCTT=$PIECE(SCTS," (SCT ")
+10 SET SCTC=$PIECE($PIECE(SCTS,"SCT ",2),")")
+11 SET SCTD=$$GETDES^LEXTRAN1("SCT",SCTT)
+12 SET SCTD=$SELECT(+SCTD=1:$PIECE(SCTD,U,2),1:"")
End DoDot:2
+13 SET X=$$TEXT^GMPLBLD1(X)
IF X="^"
SET GMPQUIT=1
QUIT
+14 SET CODE=$$CODE^GMPLBLD1($GET(SCTC),$GET(Y(1)))
IF CODE']""
SET GMPQUIT=1
QUIT
+15 ; dflt = next #
SET RT1="^TMP(""GMPLIST"",$J,""SEQ"","
SET SEQ=+$$LAST^GMPLBLD2(RT1)+1
+16 SET SEQ=$$SEQ^GMPLBLD1(SEQ)
IF SEQ="^"
SET GMPQUIT=1
QUIT
+17 SET IFN=$$TMPIFN^GMPLBLD1
SET ^TMP("GMPLIST",$JOB,0)=^TMP("GMPLIST",$JOB,0)+1
+18 ; seq ^ # ^ text ^ code
SET ^TMP("GMPLIST",$JOB,IFN)=SEQ_U_+Y_U_X_U_CODE_U_SCTC_U_SCTD
+19 SET (^TMP("GMPLIST",$JOB,"PROB",+Y),^TMP("GMPLIST",$JOB,"SEQ",SEQ))=IFN
SET GMPREBLD=1
End DoDot:1
IF $DATA(GMPQUIT)
QUIT
WRITE !!
+20 IF $DATA(GMPREBLD)
SET VALMBCK="R"
SET GMPLSAVE=1
DO BUILD("^TMP(""GMPLIST"",$J)",GMPLMODE)
DO HDR
+21 SET VALMBCK="R"
SET VALMSG=$$MSG^GMPLX
+22 QUIT
+23 ;
REMOVE ; Remove problem from group
+1 NEW NUM,IFN
SET VALMBCK=""
+2 SET NUM=$$SEL1^GMPLBLD1
IF NUM="^"
GOTO RMQ
+3 SET IFN=$PIECE($GET(^TMP("GMPLST",$JOB,"B",NUM)),U,1)
IF +IFN'>0
GOTO RMQ
+4 IF "@"[$GET(^TMP("GMPLIST",$JOB,IFN))
WRITE $CHAR(7),!!,"Problem does not exist in this category!"
HANG 2
GOTO RMQ
+5 IF '$$SURE^GMPLX
WRITE !?5,"< Nothing removed! >"
HANG 1
GOTO RMQ
+6 DO DELETE^GMPLBLD1(IFN)
SET VALMBCK="R"
SET GMPLSAVE=1
+7 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 SET SEL=$$SEL^GMPLBLD1
IF SEL="^"
GOTO EDQ
+3 FOR PIECE=1:1:$LENGTH(SEL,",")
Begin DoDot:1
+4 SET NUM=$PIECE(SEL,",",PIECE)
IF NUM'>0
QUIT
+5 SET IFN=$PIECE($GET(^TMP("GMPLST",$JOB,"B",NUM)),U,1)
IF IFN'>0
QUIT
+6 IF "@"[$GET(^TMP("GMPLIST",$JOB,IFN))
WRITE $CHAR(7),!!,"Problem #"_NUM_" does not exist in this category!"
HANG 2
QUIT
+7 WRITE !!,">>> Problem #"_NUM
SET PROBLEM=^TMP("GMPLIST",$JOB,IFN)
+8 ; KER
IF $PIECE(PROBLEM,U,2)>1
WRITE " = "_$GET(^LEX(757.01,+$PIECE(PROBLEM,U,2),0))
WRITE !
+9 SET PROB=$$TEXT^GMPLBLD1($PIECE(PROBLEM,U,3))
IF PROB="^"
SET GMPQUIT=1
QUIT
+10 IF PROB="@"
DO DELETE^GMPLBLD1(IFN)
SET GMPREBLD=1
QUIT
+11 SET CODE=$$CODE^GMPLBLD1($PIECE(PROBLEM,U,5),$PIECE(PROBLEM,U,4))
IF CODE="^"
SET GMPQUIT=1
QUIT
+12 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 !
+13 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
