- GMPLEDT4 ; SLC/MKB/TC -- Problem List Edit actions cont ;04/22/15 13:09
- ;;2.0;Problem List;**5,43,42,47,45**;Aug 25, 1994;Build 53
- TERM ; edit field 1.01
- N DTOUT,PROB,TERM,ICD,DUP,Y,GMPLCSYS,GMPL0,GMPL802,GMPIMPDT
- S GMPIMPDT=$$IMPDATE^LEXU("10D")
- 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
- I +Y'>0 S GMPQUIT=1 Q
- S DUP=$$DUPL^GMPLX(+GMPDFN,+Y,PROB)
- I DUP,'$$DUPLOK^GMPLX(DUP) S (Y,GMPROB)="" W ! G T1
- S TERM=$S(+$G(Y)>1:Y,1:""),ICD=$G(Y(1))
- S:'$L(ICD) ICD=$S(DT<GMPIMPDT:"799.9",1:"R69.")
- N I,GMPSTAT,GMPCSREC,GMPCSPTR,GMPCSNME,GMPSCTC,GMPSCTD,GMPTXT,GMPTYP,GMPNUM,GMPQT,GMPSYN
- S (GMPTYP,GMPNUM,GMPQT)=""
- I ICD["/" F I=1:1:$L(ICD,"/") D Q:GMPSTAT
- . N GMPCODE S GMPCODE=$P(ICD,"/",I),GMPSTAT=0
- . S GMPCSREC=$$CODECS^ICDEX(GMPCODE,80,DT),GMPCSPTR=$P(GMPCSREC,U),GMPCSNME=$P(GMPCSREC,U,2)
- . S:'+$$STATCHK^ICDXCODE(GMPCSPTR,GMPCODE,DT) GMPSTAT=1
- E D
- . S GMPSTAT=0,GMPCSREC=$$CODECS^ICDEX(ICD,80,DT),GMPCSPTR=$P(GMPCSREC,U),GMPCSNME=$P(GMPCSREC,U,2)
- . S:'+$$STATCHK^ICDXCODE(GMPCSPTR,ICD,DT) GMPSTAT=1
- I GMPSTAT W !,PROB,!,"has an inactive ICD code. Please enter another search term." H 3 Q
- I (PROB["(SCT"),(PROB[")") D
- . S GMPSCTC=$$ONE^LEXU(+TERM,DT,"SCT")
- . S GMPTXT=$$TRIM^XLFSTR($RE($P($RE(PROB),"(",2,99)))
- . S GMPSCTD=$$GETSYN^LEXTRAN1("SCT",GMPSCTC,DT,"GMPSYN",1,1)
- . I $P(GMPSCTD,U)'=1 S GMPSCTD="" Q
- . F S GMPTYP=$O(GMPSYN(GMPTYP)) Q:GMPTYP=""!(GMPQT) D
- . . I GMPTYP="S" F S GMPNUM=$O(GMPSYN(GMPTYP,GMPNUM)) Q:GMPNUM=""!(GMPQT) D
- . . . I $P(GMPSYN(GMPTYP,GMPNUM),U)=GMPTXT S GMPSCTD=$P(GMPSYN(GMPTYP,GMPNUM),U,3),GMPQT=1 Q
- . . Q:GMPQT
- . . I $P(GMPSYN(GMPTYP),U)=GMPTXT S GMPSCTD=$P(GMPSYN(GMPTYP),U,3),GMPQT=1 Q
- S GMPLCSYS=$$SAB^ICDEX(GMPCSPTR,DT)
- S GMPFLD(1.01)=TERM,GMPFLD(.05)=U_PROB
- S GMPFLD(.01)=$S($L(ICD):$P($$ICDDATA^ICDXCODE(GMPCSPTR,$P(ICD,"/"),DT,"E"),U)_U_$G(ICD),1:"")
- S:'GMPFLD(.01)!($P(GMPFLD(.01),U)<0) GMPFLD(.01)=$$NOS^GMPLX(GMPLCSYS,DT)
- S (GMPFLD(.03),GMPFLD(80201),GMPFLD(1.09))=DT_U_$$EXTDT^GMPLX(DT)
- S GMPFLD(80202)=GMPLCSYS_U_$G(GMPCSNME)
- S GMPFLD(80001)=GMPSCTC_U_GMPSCTC,GMPFLD(80002)=GMPSCTD_U_GMPSCTD
- K GMPSYN
- 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 S DIR(0)="FAO^1:200",DIR("A")=PROMPT
- S:$L(DEFAULT) DIR("B")=DEFAULT
- S DIR("?",1)="Enter any text you wish appended to this problem, up to 200 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)>200 W !!,"Text may not exceed 200 characters!",!,$C(7) S DIR("B")=$E(X,1,200) G ED1
- S Y=X
- Q
- ;
- RESOLVED ; edit field 1.07
- N X,Y,PROMPT,HELPMSG,DEFAULT,ONSET 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
- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMPLEDT4 5555 printed Apr 23, 2025@18:44:32 Page 2
- GMPLEDT4 ; SLC/MKB/TC -- Problem List Edit actions cont ;04/22/15 13:09
- +1 ;;2.0;Problem List;**5,43,42,47,45**;Aug 25, 1994;Build 53
- TERM ; edit field 1.01
- +1 NEW DTOUT,PROB,TERM,ICD,DUP,Y,GMPLCSYS,GMPL0,GMPL802,GMPIMPDT
- +2 SET GMPIMPDT=$$IMPDATE^LEXU("10D")
- 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 IF +Y'>0
- SET GMPQUIT=1
- QUIT
- +4 SET DUP=$$DUPL^GMPLX(+GMPDFN,+Y,PROB)
- +5 IF DUP
- IF '$$DUPLOK^GMPLX(DUP)
- SET (Y,GMPROB)=""
- WRITE !
- GOTO T1
- +6 SET TERM=$SELECT(+$GET(Y)>1:Y,1:"")
- SET ICD=$GET(Y(1))
- +7 if '$LENGTH(ICD)
- SET ICD=$SELECT(DT<GMPIMPDT:"799.9",1:"R69.")
- +8 NEW I,GMPSTAT,GMPCSREC,GMPCSPTR,GMPCSNME,GMPSCTC,GMPSCTD,GMPTXT,GMPTYP,GMPNUM,GMPQT,GMPSYN
- +9 SET (GMPTYP,GMPNUM,GMPQT)=""
- +10 IF ICD["/"
- FOR I=1:1:$LENGTH(ICD,"/")
- Begin DoDot:1
- +11 NEW GMPCODE
- SET GMPCODE=$PIECE(ICD,"/",I)
- SET GMPSTAT=0
- +12 SET GMPCSREC=$$CODECS^ICDEX(GMPCODE,80,DT)
- SET GMPCSPTR=$PIECE(GMPCSREC,U)
- SET GMPCSNME=$PIECE(GMPCSREC,U,2)
- +13 if '+$$STATCHK^ICDXCODE(GMPCSPTR,GMPCODE,DT)
- SET GMPSTAT=1
- End DoDot:1
- if GMPSTAT
- QUIT
- +14 IF '$TEST
- Begin DoDot:1
- +15 SET GMPSTAT=0
- SET GMPCSREC=$$CODECS^ICDEX(ICD,80,DT)
- SET GMPCSPTR=$PIECE(GMPCSREC,U)
- SET GMPCSNME=$PIECE(GMPCSREC,U,2)
- +16 if '+$$STATCHK^ICDXCODE(GMPCSPTR,ICD,DT)
- SET GMPSTAT=1
- End DoDot:1
- +17 IF GMPSTAT
- WRITE !,PROB,!,"has an inactive ICD code. Please enter another search term."
- HANG 3
- QUIT
- +18 IF (PROB["(SCT")
- IF (PROB[")")
- Begin DoDot:1
- +19 SET GMPSCTC=$$ONE^LEXU(+TERM,DT,"SCT")
- +20 SET GMPTXT=$$TRIM^XLFSTR($REVERSE($PIECE($REVERSE(PROB),"(",2,99)))
- +21 SET GMPSCTD=$$GETSYN^LEXTRAN1("SCT",GMPSCTC,DT,"GMPSYN",1,1)
- +22 IF $PIECE(GMPSCTD,U)'=1
- SET GMPSCTD=""
- QUIT
- +23 FOR
- SET GMPTYP=$ORDER(GMPSYN(GMPTYP))
- if GMPTYP=""!(GMPQT)
- QUIT
- Begin DoDot:2
- +24 IF GMPTYP="S"
- FOR
- SET GMPNUM=$ORDER(GMPSYN(GMPTYP,GMPNUM))
- if GMPNUM=""!(GMPQT)
- QUIT
- Begin DoDot:3
- +25 IF $PIECE(GMPSYN(GMPTYP,GMPNUM),U)=GMPTXT
- SET GMPSCTD=$PIECE(GMPSYN(GMPTYP,GMPNUM),U,3)
- SET GMPQT=1
- QUIT
- End DoDot:3
- +26 if GMPQT
- QUIT
- +27 IF $PIECE(GMPSYN(GMPTYP),U)=GMPTXT
- SET GMPSCTD=$PIECE(GMPSYN(GMPTYP),U,3)
- SET GMPQT=1
- QUIT
- End DoDot:2
- End DoDot:1
- +28 SET GMPLCSYS=$$SAB^ICDEX(GMPCSPTR,DT)
- +29 SET GMPFLD(1.01)=TERM
- SET GMPFLD(.05)=U_PROB
- +30 SET GMPFLD(.01)=$SELECT($LENGTH(ICD):$PIECE($$ICDDATA^ICDXCODE(GMPCSPTR,$PIECE(ICD,"/"),DT,"E"),U)_U_$GET(ICD),1:"")
- +31 if 'GMPFLD(.01)!($PIECE(GMPFLD(.01),U)<0)
- SET GMPFLD(.01)=$$NOS^GMPLX(GMPLCSYS,DT)
- +32 SET (GMPFLD(.03),GMPFLD(80201),GMPFLD(1.09))=DT_U_$$EXTDT^GMPLX(DT)
- +33 SET GMPFLD(80202)=GMPLCSYS_U_$GET(GMPCSNME)
- +34 SET GMPFLD(80001)=GMPSCTC_U_GMPSCTC
- SET GMPFLD(80002)=GMPSCTD_U_GMPSCTD
- +35 KILL GMPSYN
- +36 QUIT
- +37 ;
- 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
- SET DIR(0)="FAO^1:200"
- 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 200 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)>200
- WRITE !!,"Text may not exceed 200 characters!",!,$CHAR(7)
- SET DIR("B")=$EXTRACT(X,1,200)
- GOTO ED1
- +9 SET Y=X
- +10 QUIT
- +11 ;
- RESOLVED ; edit field 1.07
- +1 NEW X,Y,PROMPT,HELPMSG,DEFAULT,ONSET
- 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
- +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
