GMPLBLD1 ; ISL/MKB,JER,TC - Bld PL Selection Lists cont;05/02/17 11:28
;;2.0;Problem List;**3,28,36,42,49**;Aug 25, 1994;Build 43
;
; External References:
; ICR 5747 $$CODECS^ICDEX
; ICR 10026 ^DIR
; ICR 10103 $$DT^XLFDT
;
SEL() ; Select item(s) from list
N DIR,X,Y,MAX,GRP,DTOUT S GRP=$D(GMPLGRP) ; =1 if editing groups, 0 if lists
S MAX=$P($G(^TMP("GMPLST",$J,0)),U,1) I MAX'>0 Q "^"
S DIR(0)="LAO^1:"_MAX,DIR("A")="Select "_$S('GRP:"Category",1:"Problem")_"(s)"
S:MAX>1 DIR("A")=DIR("A")_" (1-"_MAX_"): "
S:MAX'>1 DIR("A")=DIR("A")_": ",DIR("B")=1
S DIR("?")="Enter the "_$S('GRP:"categories",1:"problems")_" you wish to select, as a range or list of numbers"
D ^DIR S:$D(DTOUT)!(X="") Y="^"
Q Y
;
SEL1() ; Select item from list
N DIR,X,Y,MAX,GRP,DTOUT S GRP=$D(GMPLGRP) ; =1 if editing groups, 0 if lists
S MAX=$P($G(^TMP("GMPLST",$J,0)),U,1) I MAX'>0 Q "^"
S DIR(0)="NAO^1:"_MAX_":0",DIR("A")="Select "_$S('GRP:"Category",1:"Problem")
S:MAX>1 DIR("A")=DIR("A")_" (1-"_MAX_"): "
S:MAX'>1 DIR("A")=DIR("A")_": ",DIR("B")=1
S DIR("?")="Enter the "_$S('GRP:"category",1:"problem")_" you wish to select, by number"
D ^DIR I $D(DTOUT)!(X="") S Y="^"
Q Y
;
SEQ(NUM) ; Enter/edit seq #, returns new #
N DIR,X,Y,GRP,DTOUT S GRP=$D(GMPLGRP) ; =1 if editing groups, 0 if lists
S DIR(0)="NA^.01:999.99:2",DIR("A")="SEQUENCE: " S:NUM DIR("B")=NUM
S DIR("?",1)="Enter a number indicating the sequence of this item in the "_$S('GRP:"list;",1:"category;")
S DIR("?")="up to 2 decimal places may be used, to order these items."
SQ D ^DIR I $D(DTOUT)!(X="^") Q "^"
I X?1"^".E W $C(7),$$NOJUMP G SQ
I Y=NUM Q NUM
I $D(^TMP("GMPLIST",$J,"SEQ",Y)) D G SQ
. W $C(7),!!,"Sequence number already in use! Please enter another number."
. W !,"Use the 'Change View' option to display the current sequence numbers.",!
Q Y
;
HDR(TEXT) ; Enter/edit group subheader text in list
N DIR,X,Y,DTOUT S:$L(TEXT) DIR("B")=TEXT
S DIR(0)="FAO^2:65",DIR("A")="HEADER: "
S DIR("?")="Enter the text you wish displayed as a header for this category of problems"
S:$D(DIR("B")) DIR("?",1)=DIR("?")_";",DIR("?")="enter '@' if no header text is desired."
H1 D ^DIR I $D(DTOUT)!(X="^") Q "^"
I X?1"^".E W $C(7),$$NOJUMP G H1
I X="@" Q:$$SURE^GMPLX "" G H1
Q Y
;
TEXT(TEXT) ; Edit problem text
N DIR,X,Y,DTOUT S:$L(TEXT) DIR("B")=TEXT
S DIR(0)="FAO^2:80",DIR("A")=" DISPLAY TEXT: "
S DIR("?")="Enter the text you wish presented here for this problem."
T1 D ^DIR I $D(DTOUT)!("^"[X) S Y="^" G TQ
I X?1"^".E W $C(7),$$NOJUMP G T1
I X="@" G:'$$SURE^GMPLX T1 S Y="@" G TQ
TQ Q Y
;
CODE(SCTCODE,ICDCODE) ; Confirm problem codes
N DIR,X,Y,CODESYS,GMPCSREC,DTOUT
S GMPCSREC=$$CODECS^ICDEX(ICDCODE,80,$$DT^XLFDT),CODESYS=$P(GMPCSREC,U,2)
W !!?2,"The following ",$S(SCTCODE]"":"SNOMED CT & ",1:""),CODESYS," Code(s) are associated with the problem",!?2,"you selected:"
I SCTCODE]"" W !!?2,"SNOMED CT: ",SCTCODE,?24,CODESYS,": ",ICDCODE,!
E W !!?2,CODESYS,": ",ICDCODE,!
S DIR(0)="YA",DIR("A")=" ... Yes? "
S DIR("?")="Please indicate ((Y)es or (N)o) whether the problem/code(s) specified are appropriate."
C1 D ^DIR I $D(DTOUT)!(X="^") S Y="^" G CQ
I X?1"^".E W $C(7),$$NOJUMP G C1
I X="@" G:'$$SURE^GMPLX C1 S Y=""
S:+Y'>0 Y="" S:+Y>0 Y=ICDCODE
W !
CQ Q Y
;
FLAG(DFLT) ; Edit category flag
N DIR,X,Y,DTOUT S DIR(0)="YAO",DIR("B")=$S(+DFLT:"YES",1:"NO")
S DIR("A")="SHOW PROBLEMS AUTOMATICALLY? "
S DIR("?",1)="Enter YES if you wish the problems contained in this category to be",DIR("?",2)="automatically displayed upon entry to this list; NO will display only the",DIR("?")="category header until the user selects it to view."
F1 D ^DIR I $D(DTOUT)!(X="^") Q "^"
I X?1"^".E W $C(7),$$NOJUMP G F1
Q Y
;
NOJUMP() ; Message
Q " ^-jumping not allowed!"
;
RETURN() ; End of page prompt
N DIR,X,Y
S DIR(0)="E" D ^DIR
Q +Y
;
TMPIFN() ; Get temporary IFN ("#N") for ^TMP("GMPLIST",$J,)
N I,LAST S (I,LAST)=0
F S I=$O(^TMP("GMPLIST",$J,I)) Q:+I'>0 S:I?1.N1"N" LAST=+I
S I=LAST+1,I=$E("0000",1,4-$L(I))_I
TMPQ Q I_"N"
;
DELETE(IFN) ; Kill entry in ^TMP("GMPLIST",$J,)
N SEQ,GROUP S ^TMP("GMPLIST",$J,0)=^TMP("GMPLIST",$J,0)-1
S SEQ=$P(^TMP("GMPLIST",$J,IFN),U,2),GROUP=$P(^TMP("GMPLIST",$J,IFN),U,1),^TMP("GMPLIST",$J,IFN)="@"
K ^TMP("GMPLIST",$J,"SEQ",SEQ),^TMP("GMPLIST",$J,"PROB",GROUP),^TMP("GMPLIST",$J,"GRP",GROUP)
K:IFN?1.N1"N" ^TMP("GMPLIST",$J,IFN)
Q
;
RESEQ ; Resequence items
N SEL,NUM,SEQ,NSEQ,PIECE,IFN,GMPQUIT S VALMBCK=""
I $P($G(GMPLGRP),U,4)="N" W !!,"Cannot make edits to a National category." H 2 G RSQ
I $P($G(GMPLSLST),U,5)="N",'$D(GMPLGRP) W !!,"Cannot make edits to a National list." H 2 G RSQ
S SEL=$$SEL G:SEL="^" RSQ
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 S SEQ=$P(^TMP("GMPLIST",$J,IFN),U,2)
. W !!,$P(^TMP("GMPLIST",$J,IFN),U,3)
. S NSEQ=$$SEQ(SEQ) I NSEQ="^" S GMPQUIT=1 Q
.I SEQ'=NSEQ S ^TMP("GMPLIST",$J,IFN)=$P(^TMP("GMPLIST",$J,IFN),U,1)_U_NSEQ_U_$P(^TMP("GMPLIST",$J,IFN),U,3,$L(^TMP("GMPLIST",$J,IFN),U)),^TMP("GMPLIST",$J,"SEQ",NSEQ)=IFN,GMPREBLD=1 K ^TMP("GMPLIST",$J,"SEQ",SEQ)
I $D(GMPREBLD) S VALMBCK="R",GMPLSAVE=1 ; D BUILD in exit action
RSQ S:'VALMCC VALMBCK="R" S VALMSG=$$MSG^GMPLX
Q
;
EDIT ; Edit category display
N GRPS,NUM,IFN,HDR,FLG,PIECE,GMPQUIT,GMPREBLD S VALMBCK=""
I $P($G(GMPLSLST),U,5)="N" W !!,"Cannot make edits to a National list." H 2 G EDQ
S GRPS=$$SEL G:GRPS="^" EDQ
F PIECE=1:1:$L(GRPS,",") D Q:$D(GMPQUIT) W !
. S NUM=$P(GRPS,",",PIECE) Q:NUM'>0
.S IFN=$P($G(^TMP("GMPLST",$J,"B",NUM)),U,1) Q:+IFN'>0
. S HDR=$P(^TMP("GMPLIST",$J,IFN),U,3),FLG=$P(^TMP("GMPLIST",$J,IFN),U,4)
. S HDR=$$HDR(HDR) I HDR="^" S GMPQUIT=1 Q
. S FLG=$$FLAG(FLG) I FLG="^" S GMPQUIT=1 Q
. S $P(^TMP("GMPLIST",$J,IFN),U,3,4)=HDR_U_FLG,GMPREBLD=1
I $D(GMPREBLD) S VALMBCK="R",GMPLSAVE=1 D BUILD^GMPLBLD("^TMP(""GMPLIST"",$J)",GMPLMODE)
EDQ S:'VALMCC VALMBCK="R" S VALMSG=$$MSG^GMPLX
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMPLBLD1 6127 printed Sep 23, 2025@20:05:55 Page 2
GMPLBLD1 ; ISL/MKB,JER,TC - Bld PL Selection Lists cont;05/02/17 11:28
+1 ;;2.0;Problem List;**3,28,36,42,49**;Aug 25, 1994;Build 43
+2 ;
+3 ; External References:
+4 ; ICR 5747 $$CODECS^ICDEX
+5 ; ICR 10026 ^DIR
+6 ; ICR 10103 $$DT^XLFDT
+7 ;
SEL() ; Select item(s) from list
+1 ; =1 if editing groups, 0 if lists
NEW DIR,X,Y,MAX,GRP,DTOUT
SET GRP=$DATA(GMPLGRP)
+2 SET MAX=$PIECE($GET(^TMP("GMPLST",$JOB,0)),U,1)
IF MAX'>0
QUIT "^"
+3 SET DIR(0)="LAO^1:"_MAX
SET DIR("A")="Select "_$SELECT('GRP:"Category",1:"Problem")_"(s)"
+4 if MAX>1
SET DIR("A")=DIR("A")_" (1-"_MAX_"): "
+5 if MAX'>1
SET DIR("A")=DIR("A")_": "
SET DIR("B")=1
+6 SET DIR("?")="Enter the "_$SELECT('GRP:"categories",1:"problems")_" you wish to select, as a range or list of numbers"
+7 DO ^DIR
if $DATA(DTOUT)!(X="")
SET Y="^"
+8 QUIT Y
+9 ;
SEL1() ; Select item from list
+1 ; =1 if editing groups, 0 if lists
NEW DIR,X,Y,MAX,GRP,DTOUT
SET GRP=$DATA(GMPLGRP)
+2 SET MAX=$PIECE($GET(^TMP("GMPLST",$JOB,0)),U,1)
IF MAX'>0
QUIT "^"
+3 SET DIR(0)="NAO^1:"_MAX_":0"
SET DIR("A")="Select "_$SELECT('GRP:"Category",1:"Problem")
+4 if MAX>1
SET DIR("A")=DIR("A")_" (1-"_MAX_"): "
+5 if MAX'>1
SET DIR("A")=DIR("A")_": "
SET DIR("B")=1
+6 SET DIR("?")="Enter the "_$SELECT('GRP:"category",1:"problem")_" you wish to select, by number"
+7 DO ^DIR
IF $DATA(DTOUT)!(X="")
SET Y="^"
+8 QUIT Y
+9 ;
SEQ(NUM) ; Enter/edit seq #, returns new #
+1 ; =1 if editing groups, 0 if lists
NEW DIR,X,Y,GRP,DTOUT
SET GRP=$DATA(GMPLGRP)
+2 SET DIR(0)="NA^.01:999.99:2"
SET DIR("A")="SEQUENCE: "
if NUM
SET DIR("B")=NUM
+3 SET DIR("?",1)="Enter a number indicating the sequence of this item in the "_$SELECT('GRP:"list;",1:"category;")
+4 SET DIR("?")="up to 2 decimal places may be used, to order these items."
SQ DO ^DIR
IF $DATA(DTOUT)!(X="^")
QUIT "^"
+1 IF X?1"^".E
WRITE $CHAR(7),$$NOJUMP
GOTO SQ
+2 IF Y=NUM
QUIT NUM
+3 IF $DATA(^TMP("GMPLIST",$JOB,"SEQ",Y))
Begin DoDot:1
+4 WRITE $CHAR(7),!!,"Sequence number already in use! Please enter another number."
+5 WRITE !,"Use the 'Change View' option to display the current sequence numbers.",!
End DoDot:1
GOTO SQ
+6 QUIT Y
+7 ;
HDR(TEXT) ; Enter/edit group subheader text in list
+1 NEW DIR,X,Y,DTOUT
if $LENGTH(TEXT)
SET DIR("B")=TEXT
+2 SET DIR(0)="FAO^2:65"
SET DIR("A")="HEADER: "
+3 SET DIR("?")="Enter the text you wish displayed as a header for this category of problems"
+4 if $DATA(DIR("B"))
SET DIR("?",1)=DIR("?")_";"
SET DIR("?")="enter '@' if no header text is desired."
H1 DO ^DIR
IF $DATA(DTOUT)!(X="^")
QUIT "^"
+1 IF X?1"^".E
WRITE $CHAR(7),$$NOJUMP
GOTO H1
+2 IF X="@"
if $$SURE^GMPLX
QUIT ""
GOTO H1
+3 QUIT Y
+4 ;
TEXT(TEXT) ; Edit problem text
+1 NEW DIR,X,Y,DTOUT
if $LENGTH(TEXT)
SET DIR("B")=TEXT
+2 SET DIR(0)="FAO^2:80"
SET DIR("A")=" DISPLAY TEXT: "
+3 SET DIR("?")="Enter the text you wish presented here for this problem."
T1 DO ^DIR
IF $DATA(DTOUT)!("^"[X)
SET Y="^"
GOTO TQ
+1 IF X?1"^".E
WRITE $CHAR(7),$$NOJUMP
GOTO T1
+2 IF X="@"
if '$$SURE^GMPLX
GOTO T1
SET Y="@"
GOTO TQ
TQ QUIT Y
+1 ;
CODE(SCTCODE,ICDCODE) ; Confirm problem codes
+1 NEW DIR,X,Y,CODESYS,GMPCSREC,DTOUT
+2 SET GMPCSREC=$$CODECS^ICDEX(ICDCODE,80,$$DT^XLFDT)
SET CODESYS=$PIECE(GMPCSREC,U,2)
+3 WRITE !!?2,"The following ",$SELECT(SCTCODE]"":"SNOMED CT & ",1:""),CODESYS," Code(s) are associated with the problem",!?2,"you selected:"
+4 IF SCTCODE]""
WRITE !!?2,"SNOMED CT: ",SCTCODE,?24,CODESYS,": ",ICDCODE,!
+5 IF '$TEST
WRITE !!?2,CODESYS,": ",ICDCODE,!
+6 SET DIR(0)="YA"
SET DIR("A")=" ... Yes? "
+7 SET DIR("?")="Please indicate ((Y)es or (N)o) whether the problem/code(s) specified are appropriate."
C1 DO ^DIR
IF $DATA(DTOUT)!(X="^")
SET Y="^"
GOTO CQ
+1 IF X?1"^".E
WRITE $CHAR(7),$$NOJUMP
GOTO C1
+2 IF X="@"
if '$$SURE^GMPLX
GOTO C1
SET Y=""
+3 if +Y'>0
SET Y=""
if +Y>0
SET Y=ICDCODE
+4 WRITE !
CQ QUIT Y
+1 ;
FLAG(DFLT) ; Edit category flag
+1 NEW DIR,X,Y,DTOUT
SET DIR(0)="YAO"
SET DIR("B")=$SELECT(+DFLT:"YES",1:"NO")
+2 SET DIR("A")="SHOW PROBLEMS AUTOMATICALLY? "
+3 SET DIR("?",1)="Enter YES if you wish the problems contained in this category to be"
SET DIR("?",2)="automatically displayed upon entry to this list; NO will display only the"
SET DIR("?")="category header until the user selects it to view."
F1 DO ^DIR
IF $DATA(DTOUT)!(X="^")
QUIT "^"
+1 IF X?1"^".E
WRITE $CHAR(7),$$NOJUMP
GOTO F1
+2 QUIT Y
+3 ;
NOJUMP() ; Message
+1 QUIT " ^-jumping not allowed!"
+2 ;
RETURN() ; End of page prompt
+1 NEW DIR,X,Y
+2 SET DIR(0)="E"
DO ^DIR
+3 QUIT +Y
+4 ;
TMPIFN() ; Get temporary IFN ("#N") for ^TMP("GMPLIST",$J,)
+1 NEW I,LAST
SET (I,LAST)=0
+2 FOR
SET I=$ORDER(^TMP("GMPLIST",$JOB,I))
if +I'>0
QUIT
if I?1.N1"N"
SET LAST=+I
+3 SET I=LAST+1
SET I=$EXTRACT("0000",1,4-$LENGTH(I))_I
TMPQ QUIT I_"N"
+1 ;
DELETE(IFN) ; Kill entry in ^TMP("GMPLIST",$J,)
+1 NEW SEQ,GROUP
SET ^TMP("GMPLIST",$JOB,0)=^TMP("GMPLIST",$JOB,0)-1
+2 SET SEQ=$PIECE(^TMP("GMPLIST",$JOB,IFN),U,2)
SET GROUP=$PIECE(^TMP("GMPLIST",$JOB,IFN),U,1)
SET ^TMP("GMPLIST",$JOB,IFN)="@"
+3 KILL ^TMP("GMPLIST",$JOB,"SEQ",SEQ),^TMP("GMPLIST",$JOB,"PROB",GROUP),^TMP("GMPLIST",$JOB,"GRP",GROUP)
+4 if IFN?1.N1"N"
KILL ^TMP("GMPLIST",$JOB,IFN)
+5 QUIT
+6 ;
RESEQ ; Resequence items
+1 NEW SEL,NUM,SEQ,NSEQ,PIECE,IFN,GMPQUIT
SET VALMBCK=""
+2 IF $PIECE($GET(GMPLGRP),U,4)="N"
WRITE !!,"Cannot make edits to a National category."
HANG 2
GOTO RSQ
+3 IF $PIECE($GET(GMPLSLST),U,5)="N"
IF '$DATA(GMPLGRP)
WRITE !!,"Cannot make edits to a National list."
HANG 2
GOTO RSQ
+4 SET SEL=$$SEL
if SEL="^"
GOTO RSQ
+5 FOR PIECE=1:1:$LENGTH(SEL,",")
Begin DoDot:1
+6 SET NUM=$PIECE(SEL,",",PIECE)
if NUM'>0
QUIT
+7 SET IFN=$PIECE($GET(^TMP("GMPLST",$JOB,"B",NUM)),U,1)
if +IFN'>0
QUIT
SET SEQ=$PIECE(^TMP("GMPLIST",$JOB,IFN),U,2)
+8 WRITE !!,$PIECE(^TMP("GMPLIST",$JOB,IFN),U,3)
+9 SET NSEQ=$$SEQ(SEQ)
IF NSEQ="^"
SET GMPQUIT=1
QUIT
+10 IF SEQ'=NSEQ
SET ^TMP("GMPLIST",$JOB,IFN)=$PIECE(^TMP("GMPLIST",$JOB,IFN),U,1)_U_NSEQ_U_$PIECE(^TMP("GMPLIST",$JOB,IFN),U,3,$LENGTH(^TMP("GMPLIST",$JOB,IFN),U))
SET ^TMP("GMPLIST",$JOB,"SEQ",NSEQ)=IFN
SET GMPREBLD=1
KILL ^TMP("GMPLIST",$JOB,"SEQ",SEQ)
End DoDot:1
if $DATA(GMPQUIT)
QUIT
WRITE !
+11 ; D BUILD in exit action
IF $DATA(GMPREBLD)
SET VALMBCK="R"
SET GMPLSAVE=1
RSQ if 'VALMCC
SET VALMBCK="R"
SET VALMSG=$$MSG^GMPLX
+1 QUIT
+2 ;
EDIT ; Edit category display
+1 NEW GRPS,NUM,IFN,HDR,FLG,PIECE,GMPQUIT,GMPREBLD
SET VALMBCK=""
+2 IF $PIECE($GET(GMPLSLST),U,5)="N"
WRITE !!,"Cannot make edits to a National list."
HANG 2
GOTO EDQ
+3 SET GRPS=$$SEL
if GRPS="^"
GOTO EDQ
+4 FOR PIECE=1:1:$LENGTH(GRPS,",")
Begin DoDot:1
+5 SET NUM=$PIECE(GRPS,",",PIECE)
if NUM'>0
QUIT
+6 SET IFN=$PIECE($GET(^TMP("GMPLST",$JOB,"B",NUM)),U,1)
if +IFN'>0
QUIT
+7 SET HDR=$PIECE(^TMP("GMPLIST",$JOB,IFN),U,3)
SET FLG=$PIECE(^TMP("GMPLIST",$JOB,IFN),U,4)
+8 SET HDR=$$HDR(HDR)
IF HDR="^"
SET GMPQUIT=1
QUIT
+9 SET FLG=$$FLAG(FLG)
IF FLG="^"
SET GMPQUIT=1
QUIT
+10 SET $PIECE(^TMP("GMPLIST",$JOB,IFN),U,3,4)=HDR_U_FLG
SET GMPREBLD=1
End DoDot:1
if $DATA(GMPQUIT)
QUIT
WRITE !
+11 IF $DATA(GMPREBLD)
SET VALMBCK="R"
SET GMPLSAVE=1
DO BUILD^GMPLBLD("^TMP(""GMPLIST"",$J)",GMPLMODE)
EDQ if 'VALMCC
SET VALMBCK="R"
SET VALMSG=$$MSG^GMPLX
+1 QUIT
