GMPLEDT4.m

GMPLEDT4 ; SLC/MKB/TC -- Problem List Edit actions cont ;09/21/12  08:27

 ;;2.0;Problem List;**5,43**;Aug 25, 1994;Build 4

TERM ; edit field 1.01

 N PROB,TERM,ICD,DUP,Y,DTOUT,GMPQUIT

T1 W !,"PROBLEM: "_$P(GMPFLD(.05),U,2)_"//"

 R PROB:DTIME S:'$T DTOUT=1 I $D(DTOUT)!(PROB="^") S GMPQUIT=1 Q

 I PROB?1"^".E D JUMP^GMPLEDT3(PROB) Q:$D(GMPQUIT)!($G(GMPLJUMP))  K:$G(GMPIFN) GMPLJUMP G T1

 Q:PROB=""  Q:PROB=$P(GMPFLD(.05),U,2)  ; no change

 I PROB["?" D  G T1

 . W !!?4,"Enter a description of this problem, up to 80 characters.",!

 I PROB="@",'+$G(GMPIFN) D  S GMPQUIT=1 Q

 .W !!?5,$C(7),$C(7),"This problem has not yet been saved."

 .W !?5,"Enter <Q>uit and it will not be added to the list.",!!

 .K DIR S DIR("A")="Press RETURN to redisplay the problem text"

 .S DIR(0)="E" D ^DIR K DIR

 I PROB="@" D DELETE^GMPLEDT2 S:VALMBCK="Q" GMPQUIT=1 Q:$D(GMPQUIT)  G T1

T2 ; new text -- pass to look-up

 I '$D(GMPLUSER)!($D(GMPLUSER)&('GMPARAM("CLU"))) S GMPFLD(1.01)="",GMPFLD(.05)=U_PROB Q

 D SEARCH^GMPLX(.PROB,.Y,"PROBLEM: ","1") ; pass to CLU

 S TERM=$G(Y),ICD=$G(Y(1)) I +TERM'>0 S GMPQUIT=1 Q

 S DUP=$$DUPL^GMPLX(+GMPDFN,+TERM,PROB)

 I DUP,'$$DUPLOK^GMPLX(DUP) W ! G T1

 S GMPFLD(1.01)=$S(+TERM>1:TERM,1:""),GMPFLD(.05)=U_PROB

 ;S GMPFLD(.01)=$S($L(ICD):$O(^ICD9("AB",ICD_" ",0))_U_ICD,1:"")

 S GMPFLD(.01)=$S($L(ICD):$P($$CODEN^ICDCODE(ICD,80),"~")_U_ICD,1:"") ; Replacing direct global read to ^ICD9

 S:'GMPFLD(.01)!($P(GMPFLD(.01),U)<0) GMPFLD(.01)=$$NOS^GMPLX

 Q

 ;

TEXT(DFLT) ; Enter/edit provider narrative text (no lookup)

 N DIR,X,Y,DTOUT

 S DIR(0)="FAO^2:80",DIR("A")="PROBLEM: " S:$L(DFLT) DIR("B")=DFLT

 S DIR("?")="Enter a description of this problem, up to 80 characters."

 D ^DIR S:$D(DTOUT)!(X="^") Y="^" S:'$L(DFLT)&(X="") Y="^"

 Q Y

 ;

NTES ; Edit existing note, display # in XQORNOD(0)

 N NUM,NOTE,X,Y,PROMPT,DEFAULT,NT

 S NT=$S(GMPVA:7,1:5) S:$D(^XUSEC("GMPL ICD CODE",DUZ)) NT=NT+1

 S NUM=+$P(XQORNOD(0),U,3)-NT Q:NUM'>0

 S NOTE=GMPFLD(10,NUM),DEFAULT=$P(NOTE,U,3)

 S PROMPT="NOTE "_$$EXTDT^GMPLX($P(NOTE,U,5))_": "

 D EDNOTE Q:$D(GMPQUIT)

 S $P(GMPFLD(10,NUM),U,3)=Y

 Q

 ;

EDNOTE ; Edit note text given PROMPT,DEFAULT (returns X,Y)

 N DIR,DTOUT,GMPQUIT S DIR(0)="FAO^1:100",DIR("A")=PROMPT

 S:$L(DEFAULT) DIR("B")=DEFAULT

 S DIR("?",1)="Enter any text you wish appended to this problem, up to 60 characters"

 S DIR("?")="in length.  You may append as many comments to a problem as you wish."

ED1 D ^DIR I $D(DTOUT)!(Y="^") S GMPQUIT=1,Y="" Q

 I Y?1"^".E D JUMP^GMPLEDT3(Y) Q:$D(GMPQUIT)!($G(GMPLJUMP))  K:$G(GMPIFN) GMPLJUMP G ED1

 Q:Y=DEFAULT  I X="@" D  Q:$D(GMPQUIT)!(Y="")  G ED1

 . N DIR,X,DTOUT,DUOUT S DIR(0)="YAO",DIR("B")="NO"

 . S DIR("A")="   Are you sure you want to delete this comment? "

 . S DIR("?")="   Enter YES to completely remove this comment from this patient's problem."

 . W $C(7) D ^DIR I $D(DUOUT)!($D(DTOUT)) S GMPQUIT=1,Y="" Q

 . S:Y Y=""

 I $L(X)>60 W !!,"Text may not exceed 60 characters!",!,$C(7) S DIR("B")=$E(X,1,60) G ED1

 S Y=X

 Q

 ;

RESOLVED ; edit field 1.07

 N X,Y,PROMPT,HELPMSG,DEFAULT,ONSET,GMPQUIT S ONSET=+$G(GMPFLD(.13))

 S DEFAULT=$G(GMPFLD(1.07)),PROMPT="DATE RESOLVED: "

 S HELPMSG="Enter the date this problem became resolved or inactive, as precisely as known."

R1 D DATE^GMPLEDT2 Q:$D(GMPQUIT)!($G(GMPLJUMP))

 I Y,ONSET,Y<ONSET W !!,"Date Resolved cannot be prior to the Date of Onset!",$C(7) G R1

 S GMPFLD(1.07)=Y S:Y'="" GMPFLD(1.07)=GMPFLD(1.07)_U_$$EXTDT^GMPLX(Y)

 Q

 ;

PRIORITY ; edit field 1.14

 N DIR,X,Y,DTOUT,GMPQUIT

 S DIR(0)="SAO^A:ACUTE;C:CHRONIC;",DIR("A")="  (A)cute or (C)hronic? "

 S:$L($G(GMPFLD(1.14))) DIR("B")=$P(GMPFLD(1.14),U,2)

 S DIR("?",1)="  You may further refine the status of this problem by designating it",DIR("?",2)="  as ACUTE or CHRONIC; problems marked as ACUTE will be flagged on the",DIR("?")="  list display with a '*'."

PR1 D ^DIR I $D(DTOUT)!(Y="^") S GMPQUIT=1 Q

 I Y?1"^".E D JUMP^GMPLEDT3(Y) Q:$D(GMPQUIT)!($G(GMPLJUMP))  K:$G(GMPIFN) GMPLJUMP G PR1

 S:Y'="" Y=Y_U_$S(Y="A":"ACUTE",1:"CHRONIC")

 S GMPFLD(1.14)=Y

 Q

GMPLEDT4  ; SLC/MKB/TC -- Problem List Edit actions cont ;09/21/12  08:27

 +1       ;;2.0;Problem List;**5,43**;Aug 25, 1994;Build 4

TERM      ; edit field 1.01

 +1        NEW PROB,TERM,ICD,DUP,Y,DTOUT,GMPQUIT

T1         WRITE !,"PROBLEM: "_$PIECE(GMPFLD(.05),U,2)_"//"

 +1        READ PROB:DTIME

           IF '$TEST

               SET DTOUT=1

           IF $DATA(DTOUT)!(PROB="^")

               SET GMPQUIT=1

               QUIT 

 +2        IF PROB?1"^".E

               DO JUMP^GMPLEDT3(PROB)

               IF $DATA(GMPQUIT)!($GET(GMPLJUMP))

                   QUIT 

               IF $GET(GMPIFN)

                   KILL GMPLJUMP

               GOTO T1

 +3       ; no change

           IF PROB=""

               QUIT 

           IF PROB=$PIECE(GMPFLD(.05),U,2)

               QUIT 

 +4        IF PROB["?"

               Begin DoDot:1

 +5                WRITE !!?4,"Enter a description of this problem, up to 80 characters.",!

               End DoDot:1

               GOTO T1

 +6        IF PROB="@"

               IF '+$GET(GMPIFN)

                   Begin DoDot:1

 +7                    WRITE !!?5,$CHAR(7),$CHAR(7),"This problem has not yet been saved."

 +8                    WRITE !?5,"Enter <Q>uit and it will not be added to the list.",!!

 +9                    KILL DIR

                       SET DIR("A")="Press RETURN to redisplay the problem text"

 +10                   SET DIR(0)="E"

                       DO ^DIR

                       KILL DIR

                   End DoDot:1

                   SET GMPQUIT=1

                   QUIT 

 +11       IF PROB="@"

               DO DELETE^GMPLEDT2

               IF VALMBCK="Q"

                   SET GMPQUIT=1

               IF $DATA(GMPQUIT)

                   QUIT 

               GOTO T1

T2        ; new text -- pass to look-up

 +1        IF '$DATA(GMPLUSER)!($DATA(GMPLUSER)&('GMPARAM("CLU")))

               SET GMPFLD(1.01)=""

               SET GMPFLD(.05)=U_PROB

               QUIT 

 +2       ; pass to CLU

           DO SEARCH^GMPLX(.PROB,.Y,"PROBLEM: ","1")

 +3        SET TERM=$GET(Y)

           SET ICD=$GET(Y(1))

           IF +TERM'>0

               SET GMPQUIT=1

               QUIT 

 +4        SET DUP=$$DUPL^GMPLX(+GMPDFN,+TERM,PROB)

 +5        IF DUP

               IF '$$DUPLOK^GMPLX(DUP)

                   WRITE !

                   GOTO T1

 +6        SET GMPFLD(1.01)=$SELECT(+TERM>1:TERM,1:"")

           SET GMPFLD(.05)=U_PROB

 +7       ;S GMPFLD(.01)=$S($L(ICD):$O(^ICD9("AB",ICD_" ",0))_U_ICD,1:"")

 +8       ; Replacing direct global read to ^ICD9

           SET GMPFLD(.01)=$SELECT($LENGTH(ICD):$PIECE($$CODEN^ICDCODE(ICD,80),"~")_U_ICD,1:"")

 +9        IF 'GMPFLD(.01)!($PIECE(GMPFLD(.01),U)<0)

               SET GMPFLD(.01)=$$NOS^GMPLX

 +10       QUIT 

 +11      ;

TEXT(DFLT) ; Enter/edit provider narrative text (no lookup)

 +1        NEW DIR,X,Y,DTOUT

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

           SET DIR("A")="PROBLEM: "

           IF $LENGTH(DFLT)

               SET DIR("B")=DFLT

 +3        SET DIR("?")="Enter a description of this problem, up to 80 characters."

 +4        DO ^DIR

           IF $DATA(DTOUT)!(X="^")

               SET Y="^"

           IF '$LENGTH(DFLT)&(X="")

               SET Y="^"

 +5        QUIT Y

 +6       ;

NTES      ; Edit existing note, display # in XQORNOD(0)

 +1        NEW NUM,NOTE,X,Y,PROMPT,DEFAULT,NT

 +2        SET NT=$SELECT(GMPVA:7,1:5)

           IF $DATA(^XUSEC("GMPL ICD CODE",DUZ))

               SET NT=NT+1

 +3        SET NUM=+$PIECE(XQORNOD(0),U,3)-NT

           IF NUM'>0

               QUIT 

 +4        SET NOTE=GMPFLD(10,NUM)

           SET DEFAULT=$PIECE(NOTE,U,3)

 +5        SET PROMPT="NOTE "_$$EXTDT^GMPLX($PIECE(NOTE,U,5))_": "

 +6        DO EDNOTE

           IF $DATA(GMPQUIT)

               QUIT 

 +7        SET $PIECE(GMPFLD(10,NUM),U,3)=Y

 +8        QUIT 

 +9       ;

EDNOTE    ; Edit note text given PROMPT,DEFAULT (returns X,Y)

 +1        NEW DIR,DTOUT,GMPQUIT

           SET DIR(0)="FAO^1:100"

           SET DIR("A")=PROMPT

 +2        IF $LENGTH(DEFAULT)

               SET DIR("B")=DEFAULT

 +3        SET DIR("?",1)="Enter any text you wish appended to this problem, up to 60 characters"

 +4        SET DIR("?")="in length.  You may append as many comments to a problem as you wish."

ED1        DO ^DIR

           IF $DATA(DTOUT)!(Y="^")

               SET GMPQUIT=1

               SET Y=""

               QUIT 

 +1        IF Y?1"^".E

               DO JUMP^GMPLEDT3(Y)

               IF $DATA(GMPQUIT)!($GET(GMPLJUMP))

                   QUIT 

               IF $GET(GMPIFN)

                   KILL GMPLJUMP

               GOTO ED1

 +2        IF Y=DEFAULT

               QUIT 

           IF X="@"

               Begin DoDot:1

 +3                NEW DIR,X,DTOUT,DUOUT

                   SET DIR(0)="YAO"

                   SET DIR("B")="NO"

 +4                SET DIR("A")="   Are you sure you want to delete this comment? "

 +5                SET DIR("?")="   Enter YES to completely remove this comment from this patient's problem."

 +6                WRITE $CHAR(7)

                   DO ^DIR

                   IF $DATA(DUOUT)!($DATA(DTOUT))

                       SET GMPQUIT=1

                       SET Y=""

                       QUIT 

 +7                IF Y

                       SET Y=""

               End DoDot:1

               IF $DATA(GMPQUIT)!(Y="")

                   QUIT 

               GOTO ED1

 +8        IF $LENGTH(X)>60

               WRITE !!,"Text may not exceed 60 characters!",!,$CHAR(7)

               SET DIR("B")=$EXTRACT(X,1,60)

               GOTO ED1

 +9        SET Y=X

 +10       QUIT 

 +11      ;

RESOLVED  ; edit field 1.07

 +1        NEW X,Y,PROMPT,HELPMSG,DEFAULT,ONSET,GMPQUIT

           SET ONSET=+$GET(GMPFLD(.13))

 +2        SET DEFAULT=$GET(GMPFLD(1.07))

           SET PROMPT="DATE RESOLVED: "

 +3        SET HELPMSG="Enter the date this problem became resolved or inactive, as precisely as known."

R1         DO DATE^GMPLEDT2

           IF $DATA(GMPQUIT)!($GET(GMPLJUMP))

               QUIT 

 +1        IF Y

               IF ONSET

                   IF Y<ONSET

                       WRITE !!,"Date Resolved cannot be prior to the Date of Onset!",$CHAR(7)

                       GOTO R1

 +2        SET GMPFLD(1.07)=Y

           IF Y'=""

               SET GMPFLD(1.07)=GMPFLD(1.07)_U_$$EXTDT^GMPLX(Y)

 +3        QUIT 

 +4       ;

PRIORITY  ; edit field 1.14

 +1        NEW DIR,X,Y,DTOUT,GMPQUIT

 +2        SET DIR(0)="SAO^A:ACUTE;C:CHRONIC;"

           SET DIR("A")="  (A)cute or (C)hronic? "

 +3        IF $LENGTH($GET(GMPFLD(1.14)))

               SET DIR("B")=$PIECE(GMPFLD(1.14),U,2)

 +4        SET DIR("?",1)="  You may further refine the status of this problem by designating it"

           SET DIR("?",2)="  as ACUTE or CHRONIC; problems marked as ACUTE will be flagged on the"

           SET DIR("?")="  list display with a '*'."

PR1        DO ^DIR

           IF $DATA(DTOUT)!(Y="^")

               SET GMPQUIT=1

               QUIT 

 +1        IF Y?1"^".E

               DO JUMP^GMPLEDT3(Y)

               IF $DATA(GMPQUIT)!($GET(GMPLJUMP))

                   QUIT 

               IF $GET(GMPIFN)

                   KILL GMPLJUMP

               GOTO PR1

 +2        IF Y'=""

               SET Y=Y_U_$SELECT(Y="A":"ACUTE",1:"CHRONIC")

 +3        SET GMPFLD(1.14)=Y

 +4        QUIT