- 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 Feb 18, 2025@23:56:21 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
