Routine: GMPLBLD1

GMPLBLD1 ; ISL/MKB,JER - Bld PL Selection Lists cont ;09/22/11  14:40

 ;;2.0;Problem List;**3,28,36**;Aug 25, 1994;Build 65

 ; This routine invokes IA #3991,#10082

SEL() ; Select item(s) from list

 N DIR,X,Y,MAX,GRP 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 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 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 S:$L(TEXT) DIR("B")=TEXT

 S DIR(0)="FAO^2:30",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 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

 S CODESYS="ICD-9-CM"

 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")="  ... Ok? "

 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 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,ITEM S ^TMP("GMPLIST",$J,0)=^TMP("GMPLIST",$J,0)-1

 S SEQ=+^TMP("GMPLIST",$J,IFN),ITEM=$P(^TMP("GMPLIST",$J,IFN),U,2),^TMP("GMPLIST",$J,IFN)="@"

 K ^TMP("GMPLIST",$J,"SEQ",SEQ),^TMP("GMPLIST",$J,"PROB",ITEM),^TMP("GMPLIST",$J,"GRP",ITEM)

 K:IFN?1.N1"N" ^TMP("GMPLIST",$J,IFN)

RESEQ ; Resequence items

 N SEL,NUM,SEQ,NSEQ,PIECE,IFN,GMPQUIT S VALMBCK=""

 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,1)

 . 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)=NSEQ_U_$P(^TMP("GMPLIST",$J,IFN),U,2,$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

EDIT ; Edit category display

 N GRPS,NUM,IFN,HDR,FLG,PIECE,GMPQUIT,GMPREBLD S VALMBCK=""

 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

GMPLBLD1  ; ISL/MKB,JER - Bld PL Selection Lists cont ;09/22/11  14:40

 +1       ;;2.0;Problem List;**3,28,36**;Aug 25, 1994;Build 65

 +2       ;

 +3       ; This routine invokes IA #3991,#10082

 +4       ;

SEL()     ; Select item(s) from list

 +1       ; =1 if editing groups, 0 if lists

           NEW DIR,X,Y,MAX,GRP

           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

           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

           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

           IF $LENGTH(TEXT)

               SET DIR("B")=TEXT

 +2        SET DIR(0)="FAO^2:30"

           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

           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

 +2        SET CODESYS="ICD-9-CM"

 +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")="  ... Ok? "

 +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

           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,ITEM

           SET ^TMP("GMPLIST",$JOB,0)=^TMP("GMPLIST",$JOB,0)-1

 +2        SET SEQ=+^TMP("GMPLIST",$JOB,IFN)

           SET ITEM=$PIECE(^TMP("GMPLIST",$JOB,IFN),U,2)

           SET ^TMP("GMPLIST",$JOB,IFN)="@"

 +3        KILL ^TMP("GMPLIST",$JOB,"SEQ",SEQ),^TMP("GMPLIST",$JOB,"PROB",ITEM),^TMP("GMPLIST",$JOB,"GRP",ITEM)

 +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        SET SEL=$$SEL

           IF SEL="^"

               GOTO RSQ

 +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

                   SET SEQ=$PIECE(^TMP("GMPLIST",$JOB,IFN),U,1)

 +6                WRITE !!,$PIECE(^TMP("GMPLIST",$JOB,IFN),U,3)

 +7                SET NSEQ=$$SEQ(SEQ)

                   IF NSEQ="^"

                       SET GMPQUIT=1

                       QUIT

 +8                IF SEQ'=NSEQ

                       SET ^TMP("GMPLIST",$JOB,IFN)=NSEQ_U_$PIECE(^TMP("GMPLIST",$JOB,IFN),U,2,$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 !

 +9       ; 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        SET GRPS=$$SEL

           IF GRPS="^"

               GOTO EDQ

 +3        FOR PIECE=1:1:$LENGTH(GRPS,",")

               Begin DoDot:1

 +4                SET NUM=$PIECE(GRPS,",",PIECE)

                   IF NUM'>0

                       QUIT

 +5                SET IFN=$PIECE($GET(^TMP("GMPLST",$JOB,"B",NUM)),U,1)

                   IF +IFN'>0

                       QUIT

 +6                SET HDR=$PIECE(^TMP("GMPLIST",$JOB,IFN),U,3)

                   SET FLG=$PIECE(^TMP("GMPLIST",$JOB,IFN),U,4)

 +7                SET HDR=$$HDR(HDR)

                   IF HDR="^"

                       SET GMPQUIT=1

                       QUIT

 +8                SET FLG=$$FLAG(FLG)

                   IF FLG="^"

                       SET GMPQUIT=1

                       QUIT

 +9                SET $PIECE(^TMP("GMPLIST",$JOB,IFN),U,3,4)=HDR_U_FLG

                   SET GMPREBLD=1

               End DoDot:1

               IF $DATA(GMPQUIT)

                   QUIT

               WRITE !

 +10       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

GMPLBLD1.m