GMPL1 ; SLC/MKB/AJB/TC,PWC - Problem List actions ;04/03/2019
;;2.0;Problem List;**3,20,28,43,42,45,49,54**;Aug 25, 1994;Build 1
; 10 MAR 2000 - MA - Added to the routine another user prompt
; to backup and refine Lexicon search if ICD code 799.9 or R69.
ADD ;add new entry to list - Requires GMPDFN
N GMPROB,GMPTERM,GMPICD,Y,DUP,GMPIMPDT W !
S GMPIMPDT=$$IMPDATE^LEXU("10D")
S GMPROB=$$TEXT^GMPLEDT4("") I GMPROB="^" S GMPQUIT=1 Q
I 'GMPARAM("CLU")!('$D(GMPLUSER)&('$D(^XUSEC("GMPL ICD CODE",DUZ)))) S GMPTERM="",GMPICD=$S(DT<GMPIMPDT:"799.9",1:"R69.") G ADD1
F D Q:$D(GMPQUIT)!(+$G(Y))
. D SEARCH^GMPLX(.GMPROB,.Y,"PROBLEM: ","1")
. I +Y'>0 S GMPQUIT=1 Q
. S DUP=$$DUPL^GMPLX(+GMPDFN,+Y,GMPROB)
. I DUP,'$$DUPLOK^GMPLX(DUP) S (Y,GMPROB)=""
. I +Y=1 D ICDMSG
Q:$D(GMPQUIT)
S GMPTERM=$S(+$G(Y)>1:Y,1:""),GMPICD=$G(Y(1))
S:'$L(GMPICD) GMPICD=$S(DT<GMPIMPDT:"799.9",1:"R69.")
ADD1 ; set up default values
; -- May enter here with GMPROB=text,GMPICD=code,GMPTERM=#^term
; added for Code Set Versioning (CSV)
N I,GMPSTAT,GMPCSREC,GMPCSPTR,GMPCSNME,GMPSCTC,GMPSCTD,GMPTXT,GMPTYP,GMPNUM,GMPQT,GMPSYN
S (GMPSCTC,GMPSCTD,GMPTXT,GMPTYP)="",(GMPNUM,GMPQT)=0
I GMPICD["/" F I=1:1:$L(GMPICD,"/") D Q:GMPSTAT
. N GMPCODE S GMPCODE=$P(GMPICD,"/",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(GMPICD,80,DT),GMPCSPTR=$P(GMPCSREC,U),GMPCSNME=$P(GMPCSREC,U,2)
. S:'+$$STATCHK^ICDXCODE(GMPCSPTR,GMPICD,DT) GMPSTAT=1
I GMPSTAT W !,GMPROB,!,"has an inactive ICD code. Please edit before adding." H 3 Q
I (GMPROB["(SCT"),(GMPROB[")") D
. S GMPSCTC=$$ONE^LEXU(+GMPTERM,DT,"SCT")
. I 'GMPSCTC S GMPSCTC=$P($P(GMPROB,"SCT ",2),")")
. S GMPTXT=$$STRIPSPC^GMPLX($$TRIM^XLFSTR($RE($P($RE(GMPROB),"(",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 $$STRIPSPC^GMPLX($P(GMPSYN(GMPTYP,GMPNUM),U))=GMPTXT S GMPSCTD=$P(GMPSYN(GMPTYP,GMPNUM),U,3),GMPQT=1 Q
. . I (GMPNUM=""),(GMPSCTD="") S GMPQT=1 Q
. . Q:GMPQT
. . I $$STRIPSPC^GMPLX($P(GMPSYN(GMPTYP),U))=GMPTXT S GMPSCTD=$P(GMPSYN(GMPTYP),U,3),GMPQT=1 Q
N OK,GMPI,GMPFLD K GMPLJUMP,GMPSYN
S GMPFLD(1.01)=GMPTERM,GMPFLD(.05)=U_GMPROB
S GMPFLD(.01)=$P($$ICDDATA^ICDXCODE(GMPCSPTR,$P(GMPICD,"/"),DT,"E"),U)_U_GMPICD
S GMPFLD(80202)=$$SAB^ICDEX(GMPCSPTR,DT)_U_$G(GMPCSNME)
S:'GMPFLD(.01)!($P(GMPFLD(.01),U)<0) GMPFLD(.01)=$$NOS^GMPLX($P(GMPFLD(80202),U),DT) ; cannot resolve code
S (GMPFLD(1.04),GMPFLD(1.05))=$G(GMPROV),GMPFLD(1.03)=DUZ
S GMPFLD(1.06)=$$SERVICE^GMPLX1(+GMPFLD(1.04)),GMPFLD(1.08)=$G(GMPCLIN)
S (GMPFLD(.08),GMPFLD(80201),GMPFLD(1.09))=DT_U_$$EXTDT^GMPLX(DT)
S GMPFLD(.12)="A^ACTIVE",GMPFLD(1.14)="",GMPFLD(10,0)=0
S GMPFLD(1.02)=$S('$G(GMPARAM("VER")):"P",$D(GMPLUSER):"P",1:"T")
S (GMPFLD(.13),GMPFLD(1.07))="" ; initialize dates
S GMPFLD(1.1)=$S('GMPSC:"0^NO",1:""),GMPFLD(1.11)=$S('GMPAGTOR:"0^NO",1:"")
S GMPFLD(1.12)=$S('GMPION:"0^NO",1:""),GMPFLD(1.13)=$S('GMPGULF:"0^NO",1:"")
S GMPFLD(80001)=GMPSCTC_U_GMPSCTC,GMPFLD(80002)=GMPSCTD_U_GMPSCTD
ADD2 ; prompt for values
D FLDS^GMPLEDT3 ; set GMPFLD("FLD") of editable fields
F GMPI=2:1:7 D @(GMPFLD("FLD",GMPI)_"^GMPLEDT1") Q:$D(GMPQUIT) K GMPLJUMP ; cannot ^-jump here
Q:$D(GMPQUIT)
ADD3 ; Ok to save?
S OK=$$ACCEPT^GMPLDIS1(.GMPFLD),GMPLJUMP=0 ; ok to save values?
I OK="^" W !!?10,"< Nothing Saved !! >",! S GMPQUIT=1 H 1 Q
I OK D Q ; ck DA for error?
. N I W !!,"Saving ..." D NEW^GMPLSAVE
. S I=$S(GMPLIST(0)'>0:1,GMPARAM("REV"):$O(GMPLIST(0))-.01,1:GMPLIST(0)+1)
. S GMPLIST(I)=DA,GMPLIST("B",DA)=I,GMPLIST(0)=$G(GMPLIST(0))+1
. W " done."
; Not ok -- edit values, ask again
F GMPI=1:1:GMPFLD("FLD",0) D @(GMPFLD("FLD",GMPI)_"^GMPLEDT1") Q:$D(GMPQUIT)!($D(GMPSAVED)) I $G(GMPLJUMP) S GMPI=GMPLJUMP-1 S GMPLJUMP=0 ; reset GMPI to desired fld
Q:$D(DTOUT) K GMPQUIT,DUOUT G ADD3
Q
;
; *********************************************************************
; * GMPIFN expected for the following calls:
;
STATUS ; -- inactivate problem
N DIE,DA,DR,X,Y,CHNGE,GMPFLD,PROMPT,DEFAULT
S GMPFLD(.13)=$P($G(^AUPNPROB(GMPIFN,0)),U,13) ; Onset
W !!,$$PROBTEXT^GMPLX(GMPIFN) D RESOLVED^GMPLEDT4 Q:$D(GMPQUIT)
S PROMPT="COMMENT (<60 char): ",DEFAULT="" D EDNOTE^GMPLEDT4 Q:$D(GMPQUIT)
W ! I Y'="" S GMPFLD(10,"NEW",1)=Y D NEWNOTE^GMPLSAVE W "."
; VSR - PWC GMPL*2*54 replace //// with FileMan database calls (replaced both .12 and 1.07)
N GMPLFDA,GMPLERR
S GMPLFDA(9000011,GMPIFN_",",.12)="I" ;status
S GMPLFDA(9000011,GMPIFN_",",1.07)=$P($G(GMPFLD(1.07)),U) ;date resolved
D FILE^DIE("","GMPLFDA","GMPLERR") W "."
; END OF VSR CHANGES GMPL*2*54
S CHNGE=GMPIFN_"^.12^"_$$HTFM^XLFDT($H)_U_DUZ_"^A^I^^"_+$G(GMPROV)
D AUDIT^GMPLX(CHNGE,"") W "." ; audit trail
D DTMOD^GMPLX(GMPIFN) W "." ; update Dt Last Mod
W "... inactivated!",!
H 1 S GMPSAVED=1
Q
;
NEWNOTE ; -- add a new comment
N GMPFLD
W !!,$$PROBTEXT^GMPLX(GMPIFN)
D NOTE^GMPLEDT1 Q:$D(GMPQUIT)!($D(GMPFLD(10,"NEW"))'>9)
D NEWNOTE^GMPLSAVE,DTMOD^GMPLX(GMPIFN)
S GMPSAVED=1
Q
;
DELETE ; -- delete a problem
N PROMPT,DEFAULT,X,Y,CHNGE,GMPFLD
W !!,$$PROBTEXT^GMPLX(GMPIFN)
S PROMPT="REASON FOR REMOVAL: ",DEFAULT=""
D EDNOTE^GMPLEDT4 Q:$D(GMPQUIT) W !
I Y'="" S GMPFLD(10,"NEW",1)=Y D NEWNOTE^GMPLSAVE W "."
S CHNGE=GMPIFN_"^1.02^"_$$HTFM^XLFDT($H)_U_DUZ_"^P^H^Deleted^"_+$G(GMPROV)
S $P(^AUPNPROB(GMPIFN,1),U,2)="H",GMPSAVED=1 W "."
D AUDIT^GMPLX(CHNGE,""),DTMOD^GMPLX(GMPIFN) W "."
W "... removed!",! H 1
Q
;
VERIFY ; -- verify a transcribed problem, if parameter on
N NOW,CHNGE S NOW=$$HTFM^XLFDT($H)
W !!,$$PROBTEXT^GMPLX(GMPIFN),!
I '$$CODESTS^GMPLX(GMPIFN,DT) W "has an inactive ICD code. Edit the problem before verification.",! H 2 Q
I $P($G(^AUPNPROB(GMPIFN,1)),U,2)'="T" W "does not require verification.",! H 2 Q
L +^AUPNPROB(GMPIFN,0):1 I '$T W $C(7),$$LOCKED^GMPLX,! H 2 Q
S $P(^AUPNPROB(GMPIFN,1),U,2)="P",GMPSAVED=1 W "."
S CHNGE=GMPIFN_"^1.02^"_NOW_U_DUZ_"^T^P^Verified^"_DUZ W "."
D AUDIT^GMPLX(CHNGE,""),DTMOD^GMPLX(GMPIFN) W "."
L -^AUPNPROB(GMPIFN,0) W " verified.",!
Q
ICDMSG ; If Lexicon returns ICD code 799.9 or R69.
N DIR,DTOUT,DUOUT,GMPLY,GMPROB,GMPCODE,GMPDESC,GMPIMPDT
S GMPIMPDT=$$IMPDATE^LEXU("10D"),GMPCODE=$S(DT<GMPIMPDT:"799.9",1:"R69. ")
S GMPDESC=$S(GMPCODE="799.9":"OTHER UNKNOWN AND UNSPECIFIED CAUSE OF MORBIDITY OR MORTALITY",1:"ILLNESS, UNSPECIFIED")
S DIR(0)="YAO"
S DIR("A",1)="<< If you PROCEED WITH THIS NON SPECIFIC TERM, an ICD CODE OF"_GMPCODE_" >>"
I GMPCODE="799.9" D
. S DIR("A",2)="<< "_GMPDESC_" >>"
. S DIR("A",3)="<< will be assigned. Adding more specificity to your diagnosis may >>"
. S DIR("A",4)="<< allow a more accurate ICD code. >>"
. S DIR("A",5)=""
E D
. S DIR("A",2)="<< "_GMPDESC_" will be assigned. Adding more specificity >>"
. S DIR("A",3)="<< to your diagnosis may allow a more accurate ICD code. >>"
. S DIR("A",4)=""
S DIR("A")="Continue (YES/NO) ",DIR("B")="NO"
S DIR("T")=DTIME
D ^DIR
I $D(DTOUT)!$D(DUOUT) S Y=0
I +Y=0 S (GMPLY,GMPROB)=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMPL1 7456 printed Sep 23, 2025@20:05:49 Page 2
GMPL1 ; SLC/MKB/AJB/TC,PWC - Problem List actions ;04/03/2019
+1 ;;2.0;Problem List;**3,20,28,43,42,45,49,54**;Aug 25, 1994;Build 1
+2 ; 10 MAR 2000 - MA - Added to the routine another user prompt
+3 ; to backup and refine Lexicon search if ICD code 799.9 or R69.
ADD ;add new entry to list - Requires GMPDFN
+1 NEW GMPROB,GMPTERM,GMPICD,Y,DUP,GMPIMPDT
WRITE !
+2 SET GMPIMPDT=$$IMPDATE^LEXU("10D")
+3 SET GMPROB=$$TEXT^GMPLEDT4("")
IF GMPROB="^"
SET GMPQUIT=1
QUIT
+4 IF 'GMPARAM("CLU")!('$DATA(GMPLUSER)&('$DATA(^XUSEC("GMPL ICD CODE",DUZ))))
SET GMPTERM=""
SET GMPICD=$SELECT(DT<GMPIMPDT:"799.9",1:"R69.")
GOTO ADD1
+5 FOR
Begin DoDot:1
+6 DO SEARCH^GMPLX(.GMPROB,.Y,"PROBLEM: ","1")
+7 IF +Y'>0
SET GMPQUIT=1
QUIT
+8 SET DUP=$$DUPL^GMPLX(+GMPDFN,+Y,GMPROB)
+9 IF DUP
IF '$$DUPLOK^GMPLX(DUP)
SET (Y,GMPROB)=""
+10 IF +Y=1
DO ICDMSG
End DoDot:1
if $DATA(GMPQUIT)!(+$GET(Y))
QUIT
+11 if $DATA(GMPQUIT)
QUIT
+12 SET GMPTERM=$SELECT(+$GET(Y)>1:Y,1:"")
SET GMPICD=$GET(Y(1))
+13 if '$LENGTH(GMPICD)
SET GMPICD=$SELECT(DT<GMPIMPDT:"799.9",1:"R69.")
ADD1 ; set up default values
+1 ; -- May enter here with GMPROB=text,GMPICD=code,GMPTERM=#^term
+2 ; added for Code Set Versioning (CSV)
+3 NEW I,GMPSTAT,GMPCSREC,GMPCSPTR,GMPCSNME,GMPSCTC,GMPSCTD,GMPTXT,GMPTYP,GMPNUM,GMPQT,GMPSYN
+4 SET (GMPSCTC,GMPSCTD,GMPTXT,GMPTYP)=""
SET (GMPNUM,GMPQT)=0
+5 IF GMPICD["/"
FOR I=1:1:$LENGTH(GMPICD,"/")
Begin DoDot:1
+6 NEW GMPCODE
SET GMPCODE=$PIECE(GMPICD,"/",I)
SET GMPSTAT=0
+7 SET GMPCSREC=$$CODECS^ICDEX(GMPCODE,80,DT)
SET GMPCSPTR=$PIECE(GMPCSREC,U)
SET GMPCSNME=$PIECE(GMPCSREC,U,2)
+8 if '+$$STATCHK^ICDXCODE(GMPCSPTR,GMPCODE,DT)
SET GMPSTAT=1
End DoDot:1
if GMPSTAT
QUIT
+9 IF '$TEST
Begin DoDot:1
+10 SET GMPSTAT=0
SET GMPCSREC=$$CODECS^ICDEX(GMPICD,80,DT)
SET GMPCSPTR=$PIECE(GMPCSREC,U)
SET GMPCSNME=$PIECE(GMPCSREC,U,2)
+11 if '+$$STATCHK^ICDXCODE(GMPCSPTR,GMPICD,DT)
SET GMPSTAT=1
End DoDot:1
+12 IF GMPSTAT
WRITE !,GMPROB,!,"has an inactive ICD code. Please edit before adding."
HANG 3
QUIT
+13 IF (GMPROB["(SCT")
IF (GMPROB[")")
Begin DoDot:1
+14 SET GMPSCTC=$$ONE^LEXU(+GMPTERM,DT,"SCT")
+15 IF 'GMPSCTC
SET GMPSCTC=$PIECE($PIECE(GMPROB,"SCT ",2),")")
+16 SET GMPTXT=$$STRIPSPC^GMPLX($$TRIM^XLFSTR($REVERSE($PIECE($REVERSE(GMPROB),"(",2,99))))
+17 SET GMPSCTD=$$GETSYN^LEXTRAN1("SCT",GMPSCTC,DT,"GMPSYN",1,1)
+18 IF $PIECE(GMPSCTD,U)'=1
SET GMPSCTD=""
QUIT
+19 FOR
SET GMPTYP=$ORDER(GMPSYN(GMPTYP))
if GMPTYP=""!(GMPQT)
QUIT
Begin DoDot:2
+20 IF GMPTYP="S"
FOR
SET GMPNUM=$ORDER(GMPSYN(GMPTYP,GMPNUM))
if GMPNUM=""!(GMPQT)
QUIT
Begin DoDot:3
+21 IF $$STRIPSPC^GMPLX($PIECE(GMPSYN(GMPTYP,GMPNUM),U))=GMPTXT
SET GMPSCTD=$PIECE(GMPSYN(GMPTYP,GMPNUM),U,3)
SET GMPQT=1
QUIT
End DoDot:3
+22 IF (GMPNUM="")
IF (GMPSCTD="")
SET GMPQT=1
QUIT
+23 if GMPQT
QUIT
+24 IF $$STRIPSPC^GMPLX($PIECE(GMPSYN(GMPTYP),U))=GMPTXT
SET GMPSCTD=$PIECE(GMPSYN(GMPTYP),U,3)
SET GMPQT=1
QUIT
End DoDot:2
End DoDot:1
+25 NEW OK,GMPI,GMPFLD
KILL GMPLJUMP,GMPSYN
+26 SET GMPFLD(1.01)=GMPTERM
SET GMPFLD(.05)=U_GMPROB
+27 SET GMPFLD(.01)=$PIECE($$ICDDATA^ICDXCODE(GMPCSPTR,$PIECE(GMPICD,"/"),DT,"E"),U)_U_GMPICD
+28 SET GMPFLD(80202)=$$SAB^ICDEX(GMPCSPTR,DT)_U_$GET(GMPCSNME)
+29 ; cannot resolve code
if 'GMPFLD(.01)!($PIECE(GMPFLD(.01),U)<0)
SET GMPFLD(.01)=$$NOS^GMPLX($PIECE(GMPFLD(80202),U),DT)
+30 SET (GMPFLD(1.04),GMPFLD(1.05))=$GET(GMPROV)
SET GMPFLD(1.03)=DUZ
+31 SET GMPFLD(1.06)=$$SERVICE^GMPLX1(+GMPFLD(1.04))
SET GMPFLD(1.08)=$GET(GMPCLIN)
+32 SET (GMPFLD(.08),GMPFLD(80201),GMPFLD(1.09))=DT_U_$$EXTDT^GMPLX(DT)
+33 SET GMPFLD(.12)="A^ACTIVE"
SET GMPFLD(1.14)=""
SET GMPFLD(10,0)=0
+34 SET GMPFLD(1.02)=$SELECT('$GET(GMPARAM("VER")):"P",$DATA(GMPLUSER):"P",1:"T")
+35 ; initialize dates
SET (GMPFLD(.13),GMPFLD(1.07))=""
+36 SET GMPFLD(1.1)=$SELECT('GMPSC:"0^NO",1:"")
SET GMPFLD(1.11)=$SELECT('GMPAGTOR:"0^NO",1:"")
+37 SET GMPFLD(1.12)=$SELECT('GMPION:"0^NO",1:"")
SET GMPFLD(1.13)=$SELECT('GMPGULF:"0^NO",1:"")
+38 SET GMPFLD(80001)=GMPSCTC_U_GMPSCTC
SET GMPFLD(80002)=GMPSCTD_U_GMPSCTD
ADD2 ; prompt for values
+1 ; set GMPFLD("FLD") of editable fields
DO FLDS^GMPLEDT3
+2 ; cannot ^-jump here
FOR GMPI=2:1:7
DO @(GMPFLD("FLD",GMPI)_"^GMPLEDT1")
if $DATA(GMPQUIT)
QUIT
KILL GMPLJUMP
+3 if $DATA(GMPQUIT)
QUIT
ADD3 ; Ok to save?
+1 ; ok to save values?
SET OK=$$ACCEPT^GMPLDIS1(.GMPFLD)
SET GMPLJUMP=0
+2 IF OK="^"
WRITE !!?10,"< Nothing Saved !! >",!
SET GMPQUIT=1
HANG 1
QUIT
+3 ; ck DA for error?
IF OK
Begin DoDot:1
+4 NEW I
WRITE !!,"Saving ..."
DO NEW^GMPLSAVE
+5 SET I=$SELECT(GMPLIST(0)'>0:1,GMPARAM("REV"):$ORDER(GMPLIST(0))-.01,1:GMPLIST(0)+1)
+6 SET GMPLIST(I)=DA
SET GMPLIST("B",DA)=I
SET GMPLIST(0)=$GET(GMPLIST(0))+1
+7 WRITE " done."
End DoDot:1
QUIT
+8 ; Not ok -- edit values, ask again
+9 ; reset GMPI to desired fld
FOR GMPI=1:1:GMPFLD("FLD",0)
DO @(GMPFLD("FLD",GMPI)_"^GMPLEDT1")
if $DATA(GMPQUIT)!($DATA(GMPSAVED))
QUIT
IF $GET(GMPLJUMP)
SET GMPI=GMPLJUMP-1
SET GMPLJUMP=0
+10 if $DATA(DTOUT)
QUIT
KILL GMPQUIT,DUOUT
GOTO ADD3
+11 QUIT
+12 ;
+13 ; *********************************************************************
+14 ; * GMPIFN expected for the following calls:
+15 ;
STATUS ; -- inactivate problem
+1 NEW DIE,DA,DR,X,Y,CHNGE,GMPFLD,PROMPT,DEFAULT
+2 ; Onset
SET GMPFLD(.13)=$PIECE($GET(^AUPNPROB(GMPIFN,0)),U,13)
+3 WRITE !!,$$PROBTEXT^GMPLX(GMPIFN)
DO RESOLVED^GMPLEDT4
if $DATA(GMPQUIT)
QUIT
+4 SET PROMPT="COMMENT (<60 char): "
SET DEFAULT=""
DO EDNOTE^GMPLEDT4
if $DATA(GMPQUIT)
QUIT
+5 WRITE !
IF Y'=""
SET GMPFLD(10,"NEW",1)=Y
DO NEWNOTE^GMPLSAVE
WRITE "."
+6 ; VSR - PWC GMPL*2*54 replace //// with FileMan database calls (replaced both .12 and 1.07)
+7 NEW GMPLFDA,GMPLERR
+8 ;status
SET GMPLFDA(9000011,GMPIFN_",",.12)="I"
+9 ;date resolved
SET GMPLFDA(9000011,GMPIFN_",",1.07)=$PIECE($GET(GMPFLD(1.07)),U)
+10 DO FILE^DIE("","GMPLFDA","GMPLERR")
WRITE "."
+11 ; END OF VSR CHANGES GMPL*2*54
+12 SET CHNGE=GMPIFN_"^.12^"_$$HTFM^XLFDT($HOROLOG)_U_DUZ_"^A^I^^"_+$GET(GMPROV)
+13 ; audit trail
DO AUDIT^GMPLX(CHNGE,"")
WRITE "."
+14 ; update Dt Last Mod
DO DTMOD^GMPLX(GMPIFN)
WRITE "."
+15 WRITE "... inactivated!",!
+16 HANG 1
SET GMPSAVED=1
+17 QUIT
+18 ;
NEWNOTE ; -- add a new comment
+1 NEW GMPFLD
+2 WRITE !!,$$PROBTEXT^GMPLX(GMPIFN)
+3 DO NOTE^GMPLEDT1
if $DATA(GMPQUIT)!($DATA(GMPFLD(10,"NEW"))'>9)
QUIT
+4 DO NEWNOTE^GMPLSAVE
DO DTMOD^GMPLX(GMPIFN)
+5 SET GMPSAVED=1
+6 QUIT
+7 ;
DELETE ; -- delete a problem
+1 NEW PROMPT,DEFAULT,X,Y,CHNGE,GMPFLD
+2 WRITE !!,$$PROBTEXT^GMPLX(GMPIFN)
+3 SET PROMPT="REASON FOR REMOVAL: "
SET DEFAULT=""
+4 DO EDNOTE^GMPLEDT4
if $DATA(GMPQUIT)
QUIT
WRITE !
+5 IF Y'=""
SET GMPFLD(10,"NEW",1)=Y
DO NEWNOTE^GMPLSAVE
WRITE "."
+6 SET CHNGE=GMPIFN_"^1.02^"_$$HTFM^XLFDT($HOROLOG)_U_DUZ_"^P^H^Deleted^"_+$GET(GMPROV)
+7 SET $PIECE(^AUPNPROB(GMPIFN,1),U,2)="H"
SET GMPSAVED=1
WRITE "."
+8 DO AUDIT^GMPLX(CHNGE,"")
DO DTMOD^GMPLX(GMPIFN)
WRITE "."
+9 WRITE "... removed!",!
HANG 1
+10 QUIT
+11 ;
VERIFY ; -- verify a transcribed problem, if parameter on
+1 NEW NOW,CHNGE
SET NOW=$$HTFM^XLFDT($HOROLOG)
+2 WRITE !!,$$PROBTEXT^GMPLX(GMPIFN),!
+3 IF '$$CODESTS^GMPLX(GMPIFN,DT)
WRITE "has an inactive ICD code. Edit the problem before verification.",!
HANG 2
QUIT
+4 IF $PIECE($GET(^AUPNPROB(GMPIFN,1)),U,2)'="T"
WRITE "does not require verification.",!
HANG 2
QUIT
+5 LOCK +^AUPNPROB(GMPIFN,0):1
IF '$TEST
WRITE $CHAR(7),$$LOCKED^GMPLX,!
HANG 2
QUIT
+6 SET $PIECE(^AUPNPROB(GMPIFN,1),U,2)="P"
SET GMPSAVED=1
WRITE "."
+7 SET CHNGE=GMPIFN_"^1.02^"_NOW_U_DUZ_"^T^P^Verified^"_DUZ
WRITE "."
+8 DO AUDIT^GMPLX(CHNGE,"")
DO DTMOD^GMPLX(GMPIFN)
WRITE "."
+9 LOCK -^AUPNPROB(GMPIFN,0)
WRITE " verified.",!
+10 QUIT
ICDMSG ; If Lexicon returns ICD code 799.9 or R69.
+1 NEW DIR,DTOUT,DUOUT,GMPLY,GMPROB,GMPCODE,GMPDESC,GMPIMPDT
+2 SET GMPIMPDT=$$IMPDATE^LEXU("10D")
SET GMPCODE=$SELECT(DT<GMPIMPDT:"799.9",1:"R69. ")
+3 SET GMPDESC=$SELECT(GMPCODE="799.9":"OTHER UNKNOWN AND UNSPECIFIED CAUSE OF MORBIDITY OR MORTALITY",1:"ILLNESS, UNSPECIFIED")
+4 SET DIR(0)="YAO"
+5 SET DIR("A",1)="<< If you PROCEED WITH THIS NON SPECIFIC TERM, an ICD CODE OF"_GMPCODE_" >>"
+6 IF GMPCODE="799.9"
Begin DoDot:1
+7 SET DIR("A",2)="<< "_GMPDESC_" >>"
+8 SET DIR("A",3)="<< will be assigned. Adding more specificity to your diagnosis may >>"
+9 SET DIR("A",4)="<< allow a more accurate ICD code. >>"
+10 SET DIR("A",5)=""
End DoDot:1
+11 IF '$TEST
Begin DoDot:1
+12 SET DIR("A",2)="<< "_GMPDESC_" will be assigned. Adding more specificity >>"
+13 SET DIR("A",3)="<< to your diagnosis may allow a more accurate ICD code. >>"
+14 SET DIR("A",4)=""
End DoDot:1
+15 SET DIR("A")="Continue (YES/NO) "
SET DIR("B")="NO"
+16 SET DIR("T")=DTIME
+17 DO ^DIR
+18 IF $DATA(DTOUT)!$DATA(DUOUT)
SET Y=0
+19 IF +Y=0
SET (GMPLY,GMPROB)=""
+20 QUIT
