GMPLCODE ; SLC/MKB/AJB/TC -- Problem List ICD Code Utilities ;11/27/12 08:31
;;2.0;Problem List;**28,43,42**;Aug 25, 1994;Build 46
EN ; -- main entry point for GMPL CODE LIST
K GMPLUSER
D EN^VALM("GMPL CODE LIST")
Q
;
INIT ; -- init variables and list array
S GMPDFN=$$PAT^GMPLX1 I +GMPDFN'>0 K GMPDFN S VALMQUIT=1 Q
S GMPVA=$S($G(DUZ("AG"))="V":1,1:0),GMPVAMC=+$G(DUZ(2))
S (GMPSC,GMPAGTOR,GMPION,GMPGULF)=0 D:GMPVA VADPT^GMPLX1(+GMPDFN)
S (GMPLVIEW("ACT"),GMPLVIEW("VIEW"))="",GMPLVIEW("PROV")=0
S X=$G(^GMPL(125.99,1,0)),GMPARAM("VER")=+$P(X,U,2),GMPARAM("PRT")=+$P(X,U,3),GMPARAM("CLU")=+$P(X,U,4),GMPARAM("REV")=$S($P(X,U,5)="R":1,1:0) K X
D GETPLIST^GMPLMGR1(.GMPLIST,.GMPTOTAL,.GMPLVIEW)
D BUILD^GMPLMGR(.GMPLIST)
S VALMSG=$$MSG^GMPLX
Q
;
HELP ; -- help code
N X
W !!?4,"You may take a variety of actions from this prompt. To update"
W !?4,"the ICD Code assigned to a problem, you may choose to search"
W !?4,"either the ICD Diagnosis file or the Clinical Lexicon for a"
W !?4,"match; the code of the entry you select will be assigned to the"
W !?4,"current problem in the list. If you need more information on a"
W !?4,"problem, select Detailed Display. To see a listing of"
W !?4,"actions that facilitate navigating the list, enter '??'."
W !!,"Press <return> to continue ... " R X:DTIME
S VALMSG=$$MSG^GMPLX,VALMBCK=$S(VALMCC:"",1:"R")
Q
;
EDIT ; -- edit field .01
N GMPLSEL,GMPLNO,GMPI,GMPIFN,GMPLNUM,GMPSAVED
S VALMBCK=$S(VALMCC:"",1:"R")
S GMPLSEL=$$SEL^GMPLX("code") G:GMPLSEL="^" EDQ
S GMPLNO=$L(GMPLSEL,",")
F GMPI=1:1:GMPLNO S GMPLNUM=$P(GMPLSEL,",",GMPI) I GMPLNUM D Q:$D(GMPQUIT)
. S GMPIFN=$P($G(^TMP("GMPLIDX",$J,+GMPLNUM)),U,2) Q:GMPIFN'>0
. L +^AUPNPROB(GMPIFN,0):1 I '$T W $C(7),!!,$$LOCKED^GMPLX,! H 2 Q
. D ICD(GMPLNUM,GMPIFN) L -^AUPNPROB(GMPIFN,0)
S:$D(GMPSAVED) VALMBCK="R"
EDQ D KILL^GMPLX S VALMSG=$$MSG^GMPLX
Q
;
ICD(NUM,IFN) ; -- search ICD Diagnosis file #80
N X,Y,DIC,DIR,DTOUT,DUOUT,OLD,NEW,DA,DR,DIE,LCNT,CHNGE,GMPLCSYS,GMPIMPDT,GMPLCPTR,GMPLDINT,GMPN802
W !,IFN,!
D FULL^VALM1 S VALMBCK="R" W !!
S OLD=$G(^AUPNPROB(IFN,0)),GMPN802=$G(^AUPNPROB(IFN,802))
S GMPLDINT=$S($P(GMPN802,U,1)]"":$P(GMPN802,U,1),1:$P(OLD,U,3)),GMPLCPTR=$$CSI^ICDEX(80,+OLD)
S GMPLCSYS=$S($P(GMPN802,U,2)]"":$P(GMPN802,U,2),1:$$SAB^ICDEX(GMPLCPTR,GMPLDINT))
S OLD=+OLD_U_$P($$ICDDATA^ICDXCODE(GMPLCSYS,+OLD,GMPLDINT,"I"),U,2)
S DIR(0)="PAO^ICD9(:QEM",DIR("A")="Enter ICD CODE or DESCRIPTION: "
S DIR("A",1)="Problem #"_NUM_": "_$$PROBTEXT^GMPLX(IFN)
S DIR("?")="Enter a new code number or a brief free text description on which to search",DIR("B")=$P(OLD,U,2)
; Added for Code Set Versioning (CSV) - screen allows ONLY active codes
S DIR("S")="I +($$STATCHK^ICDXCODE(GMPLCPTR,$P($$ICDDATA^ICDXCODE(GMPLCSYS,+$G(Y),DT,""I""),U,2),DT))>0"
D ^DIR I $D(DTOUT)!($D(DUOUT)) S GMPQUIT=1 Q
I X="@" Q:'$D(DIR("B")) S:$$SURE^GMPLX Y=$$NOS^GMPLX(GMPLCSYS,GMPLDINT)
I +Y>0,Y'=OLD D S GMPSAVED=1
. S NEW=Y,DIE="^AUPNPROB(",DA=IFN,DR=".01////"_+NEW D ^DIE
. S CHNGE=IFN_"^.01^"_$$HTFM^XLFDT($H)_U_DUZ_U_+OLD_U_+NEW
. D AUDIT^GMPLX(CHNGE,"")
. S LCNT=+$G(^TMP("GMPLIDX",$J,NUM))
. D FLDTEXT^VALM10(LCNT,"ICD",$P(NEW,U,2))
D BUILD^GMPLMGR(.GMPLIST) S VALMBCK="R"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMPLCODE 3294 printed Dec 13, 2024@02:29:53 Page 2
GMPLCODE ; SLC/MKB/AJB/TC -- Problem List ICD Code Utilities ;11/27/12 08:31
+1 ;;2.0;Problem List;**28,43,42**;Aug 25, 1994;Build 46
EN ; -- main entry point for GMPL CODE LIST
+1 KILL GMPLUSER
+2 DO EN^VALM("GMPL CODE LIST")
+3 QUIT
+4 ;
INIT ; -- init variables and list array
+1 SET GMPDFN=$$PAT^GMPLX1
IF +GMPDFN'>0
KILL GMPDFN
SET VALMQUIT=1
QUIT
+2 SET GMPVA=$SELECT($GET(DUZ("AG"))="V":1,1:0)
SET GMPVAMC=+$GET(DUZ(2))
+3 SET (GMPSC,GMPAGTOR,GMPION,GMPGULF)=0
if GMPVA
DO VADPT^GMPLX1(+GMPDFN)
+4 SET (GMPLVIEW("ACT"),GMPLVIEW("VIEW"))=""
SET GMPLVIEW("PROV")=0
+5 SET X=$GET(^GMPL(125.99,1,0))
SET GMPARAM("VER")=+$PIECE(X,U,2)
SET GMPARAM("PRT")=+$PIECE(X,U,3)
SET GMPARAM("CLU")=+$PIECE(X,U,4)
SET GMPARAM("REV")=$SELECT($PIECE(X,U,5)="R":1,1:0)
KILL X
+6 DO GETPLIST^GMPLMGR1(.GMPLIST,.GMPTOTAL,.GMPLVIEW)
+7 DO BUILD^GMPLMGR(.GMPLIST)
+8 SET VALMSG=$$MSG^GMPLX
+9 QUIT
+10 ;
HELP ; -- help code
+1 NEW X
+2 WRITE !!?4,"You may take a variety of actions from this prompt. To update"
+3 WRITE !?4,"the ICD Code assigned to a problem, you may choose to search"
+4 WRITE !?4,"either the ICD Diagnosis file or the Clinical Lexicon for a"
+5 WRITE !?4,"match; the code of the entry you select will be assigned to the"
+6 WRITE !?4,"current problem in the list. If you need more information on a"
+7 WRITE !?4,"problem, select Detailed Display. To see a listing of"
+8 WRITE !?4,"actions that facilitate navigating the list, enter '??'."
+9 WRITE !!,"Press <return> to continue ... "
READ X:DTIME
+10 SET VALMSG=$$MSG^GMPLX
SET VALMBCK=$SELECT(VALMCC:"",1:"R")
+11 QUIT
+12 ;
EDIT ; -- edit field .01
+1 NEW GMPLSEL,GMPLNO,GMPI,GMPIFN,GMPLNUM,GMPSAVED
+2 SET VALMBCK=$SELECT(VALMCC:"",1:"R")
+3 SET GMPLSEL=$$SEL^GMPLX("code")
if GMPLSEL="^"
GOTO EDQ
+4 SET GMPLNO=$LENGTH(GMPLSEL,",")
+5 FOR GMPI=1:1:GMPLNO
SET GMPLNUM=$PIECE(GMPLSEL,",",GMPI)
IF GMPLNUM
Begin DoDot:1
+6 SET GMPIFN=$PIECE($GET(^TMP("GMPLIDX",$JOB,+GMPLNUM)),U,2)
if GMPIFN'>0
QUIT
+7 LOCK +^AUPNPROB(GMPIFN,0):1
IF '$TEST
WRITE $CHAR(7),!!,$$LOCKED^GMPLX,!
HANG 2
QUIT
+8 DO ICD(GMPLNUM,GMPIFN)
LOCK -^AUPNPROB(GMPIFN,0)
End DoDot:1
if $DATA(GMPQUIT)
QUIT
+9 if $DATA(GMPSAVED)
SET VALMBCK="R"
EDQ DO KILL^GMPLX
SET VALMSG=$$MSG^GMPLX
+1 QUIT
+2 ;
ICD(NUM,IFN) ; -- search ICD Diagnosis file #80
+1 NEW X,Y,DIC,DIR,DTOUT,DUOUT,OLD,NEW,DA,DR,DIE,LCNT,CHNGE,GMPLCSYS,GMPIMPDT,GMPLCPTR,GMPLDINT,GMPN802
+2 WRITE !,IFN,!
+3 DO FULL^VALM1
SET VALMBCK="R"
WRITE !!
+4 SET OLD=$GET(^AUPNPROB(IFN,0))
SET GMPN802=$GET(^AUPNPROB(IFN,802))
+5 SET GMPLDINT=$SELECT($PIECE(GMPN802,U,1)]"":$PIECE(GMPN802,U,1),1:$PIECE(OLD,U,3))
SET GMPLCPTR=$$CSI^ICDEX(80,+OLD)
+6 SET GMPLCSYS=$SELECT($PIECE(GMPN802,U,2)]"":$PIECE(GMPN802,U,2),1:$$SAB^ICDEX(GMPLCPTR,GMPLDINT))
+7 SET OLD=+OLD_U_$PIECE($$ICDDATA^ICDXCODE(GMPLCSYS,+OLD,GMPLDINT,"I"),U,2)
+8 SET DIR(0)="PAO^ICD9(:QEM"
SET DIR("A")="Enter ICD CODE or DESCRIPTION: "
+9 SET DIR("A",1)="Problem #"_NUM_": "_$$PROBTEXT^GMPLX(IFN)
+10 SET DIR("?")="Enter a new code number or a brief free text description on which to search"
SET DIR("B")=$PIECE(OLD,U,2)
+11 ; Added for Code Set Versioning (CSV) - screen allows ONLY active codes
+12 SET DIR("S")="I +($$STATCHK^ICDXCODE(GMPLCPTR,$P($$ICDDATA^ICDXCODE(GMPLCSYS,+$G(Y),DT,""I""),U,2),DT))>0"
+13 DO ^DIR
IF $DATA(DTOUT)!($DATA(DUOUT))
SET GMPQUIT=1
QUIT
+14 IF X="@"
if '$DATA(DIR("B"))
QUIT
if $$SURE^GMPLX
SET Y=$$NOS^GMPLX(GMPLCSYS,GMPLDINT)
+15 IF +Y>0
IF Y'=OLD
Begin DoDot:1
+16 SET NEW=Y
SET DIE="^AUPNPROB("
SET DA=IFN
SET DR=".01////"_+NEW
DO ^DIE
+17 SET CHNGE=IFN_"^.01^"_$$HTFM^XLFDT($HOROLOG)_U_DUZ_U_+OLD_U_+NEW
+18 DO AUDIT^GMPLX(CHNGE,"")
+19 SET LCNT=+$GET(^TMP("GMPLIDX",$JOB,NUM))
+20 DO FLDTEXT^VALM10(LCNT,"ICD",$PIECE(NEW,U,2))
End DoDot:1
SET GMPSAVED=1
+21 DO BUILD^GMPLMGR(.GMPLIST)
SET VALMBCK="R"
+22 QUIT
