GMPLBLD2 ; SLC/MKB,JFR,TC -- Bld PL Selection Lists cont ;07/19/17 13:32
;;2.0;Problem List;**3,28,36,42,49**;Aug 25, 1994;Build 43
;
; External References:
; ICR 2053 $$FILE^DIE,$$UPDATE^DIE
; ICR 2336 $$GETENT,$$EDIT,$$EDITPAR^XPAREDIT
; ICR 4083 $$STATCHK^LEXSRC2
; ICR 5747 $$CODECS^ICDEX,$$STATCHK^ICDEX
; ICR 10103 $$DT^XLFDT
; ICR 10006 ^DIC
; ICR 10013 ^DIK
; ICR 10026 ^DIR
; ICR 10116 FULL^VALM1
;
NEWGRP ; Change problem groups
N NEWGRP D FULL^VALM1
I $D(GMPLSAVE),$$CKSAVE D SAVE
NG1 S NEWGRP=$$GROUP("L") G:+NEWGRP'>0 NGQ G:+NEWGRP=+GMPLGRP NGQ
L +^GMPL(125.11,+NEWGRP,0):1 I '$T D G NG1
. W $C(7),!!,"This category is currently being edited by another user!",!
L -^GMPL(125.11,+GMPLGRP,0) S GMPLGRP=NEWGRP
D GETLIST^GMPLBLDC,BUILD^GMPLBLDC("^TMP(""GMPLIST"",$J)",GMPLMODE),HDR^GMPLBLDC
NGQ S VALMBCK="R",VALMSG=$$MSG^GMPLX
Q
;
GROUP(L) ; Lookup into Problem Selection Group file #125.11
N DIC,X,Y,DLAYGO,GMPDT ; L = "" or "L", if LAYGO is [not] allowed
S GMPDT=$$DT^XLFDT
S DIC="^GMPL(125.11,",DIC(0)="AEQMZ"_L,DIC("A")="Select CATEGORY NAME: "
I DIC(0)["L" S DLAYGO=125.11,DIC("DR")=".02////"_GMPDT_";.03",DIC("?N","125.11")=6
E S DIC("S")="I $P(^(0),U,3)'=""N"""
D ^DIC S:Y'>0 Y="^" S:Y'="^" Y=+Y_U_Y(0)
Q Y
;
NEWLST ; Change selection lists
N NEWLST D FULL^VALM1
I $D(GMPLSAVE),$$CKSAVE D SAVE
NL1 S NEWLST=$$LIST("L") G:+NEWLST'>0 NLQ G:+NEWLST=+GMPLSLST NLQ
L +^GMPL(125,+NEWLST,0):1 I '$T D G NL1
. W $C(7),!!,"This list is currently being edited by another user!",!
L -^GMPL(125,+GMPLSLST,0) S GMPLSLST=NEWLST
D GETLIST^GMPLBLD,BUILD^GMPLBLD("^TMP(""GMPLIST"",$J)",GMPLMODE),HDR^GMPLBLD
NLQ S VALMBCK="R",VALMSG=$$MSG^GMPLX
Q
;
LIST(L) ; Lookup into Problem Selection List file #125
N DIC,X,Y,DLAYGO,GMPDT ; L="" or "L" if LAYGO [not] allowed
S GMPDT=$$DT^XLFDT
S DIC="^GMPL(125,",DIC(0)="AEQMZ"_L,DIC("A")="Select LIST NAME: "
S:DIC(0)["L" DLAYGO=125,DIC("DR")=".02////"_GMPDT_";.04"
D ^DIC S:Y<0!($D(DTOUT))!($D(DUOUT)) Y="^" S:Y'="^" Y=+Y_U_Y(0)
Q Y
;
LAST(ROOT) ; Returns last subscript
N I,J S (I,J)=""
F S I=$O(@(ROOT_"I)")) Q:I="" S J=I
Q J
;
CKSAVE() ; Save [changes] ??
N DIR,X,Y,TEXT S TEXT=$S($D(GMPLGRP):"category",1:"list")
S DIR("A")="Save the changes to this "_TEXT_"? ",DIR("B")="YES"
S DIR("?",1)="Enter YES to save the changes that have been made to this "_TEXT,DIR("?")="before exiting it; NO will leave this "_TEXT_" unchanged."
S DIR(0)="YA" D ^DIR
Q +Y
;
SAVE ; Save changes to group/list
N GMPLQT,LABEL,DA,GMPDT
S GMPLQT=0,GMPDT=$$DT^XLFDT
I $D(GMPLGRP) D I GMPLQT Q
. N ITM,CODE
. S ITM=0
. F S ITM=$O(^TMP("GMPLIST",$J,ITM)) Q:'ITM!(GMPLQT) D
.. N GMI,GMPSCTC
.. S GMPSCTC=$P(^TMP("GMPLIST",$J,ITM),U,5) Q:'$L(GMPSCTC)
.. I '$$STATCHK^LEXSRC2(GMPSCTC,GMPDT,"","SCT") S GMPLQT=1 Q
.. S CODE=$P(^TMP("GMPLIST",$J,ITM),U,4) Q:'$L(CODE)
.. F GMI=1:1:$L(CODE,"/") D
... N GMPLCPTR S GMPLCPTR=$P($$CODECS^ICDEX($P(CODE,"/",GMI),80,GMPDT),U)
... I '$$STATCHK^ICDEX($P(CODE,"/",GMI),GMPDT,GMPLCPTR) S GMPLQT=1 Q
. I 'GMPLQT Q ;no inactive codes in the category
. D FULL^VALM1
. W !!,$C(7),"This Group contains problems with inactive SNOMED or ICD codes associated"
. W !,"with them. The codes must be edited and corrected before the group can be saved."
. N DIR,DUOUT,DTOUT,DIRUT
. S DIR(0)="E" D ^DIR
. S VALMBCK="R",GMPLQT=1
. Q
;
I '$D(GMPLGRP),$D(GMPLSLST) D I GMPLQT Q
. N GRP
. S GRP=0
. F S GRP=$O(^TMP("GMPLIST",$J,"GRP",GRP)) Q:'GRP!(GMPLQT) D
.. I $$VALGRP(GRP) Q ;no inactive codes in the GROUP
.. S GMPLQT=1
. I 'GMPLQT Q ; all groups and problems OK
. D FULL^VALM1
. W !!,$C(7),"This Selection List contains problems with inactive SNOMED or ICD codes"
. W !,"associated with them. The codes must be edited and corrected before the"
. W !,"list can be saved."
. N DIR,DUOUT,DTOUT,DIRUT
. S DIR(0)="E" D ^DIR
. S VALMBCK="R",GMPLQT=1
. Q
W !!,"Saving ..."
S DA=0,LABEL=$S($D(GMPLGRP):"SAVGRP",1:"SAVLST")
F S DA=$O(^TMP("GMPLIST",$J,DA)) Q:+DA'>0 D @LABEL
K GMPLSAVE S:$D(GMPLGRP) GMPSAVED=1
S VALMBCK="Q" W " done." H 1
Q
SAVGRP ; Save changes to existing group
N I,DIK,ITEM,TMPITEM,GMPJ,GMPFDA,GMPERR,GMPSFN,GMPLTXT
S DA(1)=+GMPLGRP,DIK="^GMPL(125.11,"_DA(1)_",1,"
S GMPSFN="125.111"
I +DA'=DA D Q
. Q:"@"[$G(^TMP("GMPLIST",$J,DA)) ; nothing to save
. S TMPITEM=^TMP("GMPLIST",$J,DA) D NEW(GMPSFN,+GMPLGRP,TMPITEM)
I "@"[$G(^TMP("GMPLIST",$J,DA)) D ^DIK Q
S ITEM=$G(^GMPL(125.11,+GMPLGRP,1,DA,0))
I ITEM'=^TMP("GMPLIST",$J,DA) D
. F I=1:1:6 D
.. S GMPJ=$S(I=1:".01",I=2:".02",I=3:".03",I=4:".04",I=5:".05",1:".06")
.. Q:$P(^TMP("GMPLIST",$J,DA),U,I)=$P(ITEM,U,I)
.. S GMPFDA(125.111,""_DA_","_+GMPLGRP_",",GMPJ)=$S($P(^TMP("GMPLIST",$J,DA),U,I)="":"@",1:$P(^TMP("GMPLIST",$J,DA),U,I))
. D FILE^DIE("K","GMPFDA","GMPERR")
I $D(GMPERR) D
. S GMPLTXT(1)="Error updating Rec #"_+GMPLGRP_", Sub-rec #"_DA_"."
. S GMPLTXT(2)="Error "_GMPERR("DIERR",1)_": "_GMPERR("DIERR",1,"TEXT",1)
. D EN^DDIOL(.GMPLTXT)
Q
;
SAVLST ; Save changes to existing list
N I,DIK,ITEM,TMPLST,GMPJ,GMPFDA,GMPERR,GMPSFN
S DA(1)=+GMPLSLST,DIK="^GMPL(125,"_DA(1)_",1,"
S GMPSFN="125.01"
I +DA'=DA D Q ; new link
. Q:"@"[$G(^TMP("GMPLIST",$J,DA)) ; nothing to save
. S TMPLST=^TMP("GMPLIST",$J,DA) D NEW(GMPSFN,+GMPLSLST,TMPLST)
I "@"[$G(^TMP("GMPLIST",$J,DA)) D ^DIK Q
S ITEM=$G(^GMPL(125,+GMPLSLST,1,DA,0))
I ITEM'=^TMP("GMPLIST",$J,DA) D
. F I=1:1:4 D
.. S GMPJ=$S(I=1:".01",I=2:".02",I=3:".03",1:".04")
.. Q:$P(^TMP("GMPLIST",$J,DA),U,I)=$P(ITEM,U,I)
.. S GMPFDA(125.01,""_DA_","_+GMPLSLST_",",GMPJ)=$S($P(^TMP("GMPLIST",$J,DA),U,I)="":"@",1:$P(^TMP("GMPLIST",$J,DA),U,I))
. D FILE^DIE("K","GMPFDA","GMPERR")
I $D(GMPERR) D
. S GMPLTXT(1)="Error updating Rec #"_+GMPLSLST_", Sub-rec #"_DA_"."
. S GMPLTXT(2)="Error "_GMPERR("DIERR",1)_": "_GMPERR("DIERR",1,"TEXT",1)
. D EN^DDIOL(.GMPLTXT)
Q
;
NEW(GMPSFN,LIST,ITEM) ; Create new contents entry in subfile #125.01 or #125.111
N I,GMPFDA,GMPJ,GMPNF,GMPERR,GMPFILE
S GMPFILE=$S(GMPSFN="125.01":"125",1:"125.11")
S GMPNF=$S(GMPSFN="125.01":4,1:6)
F I=1:1:GMPNF D
. S GMPJ=$S(I=1:".01",I=2:".02",I=3:".03",I=4:".04",I=5:".05",1:".06")
. S GMPFDA(GMPSFN,"+2,"_LIST_",",GMPJ)=$P(ITEM,U,I)
L +^GMPL(GMPFILE,LIST):5 I '$T D Q
. W !,"Lock Error: error updating record #"_LIST_" in File #"_GMPFILE_"."
D UPDATE^DIE("","GMPFDA","","GMPERR")
L -^GMPL(GMPFILE,LIST)
Q
;
DELETE ; Delete problem group
N DIR,X,Y,DA,DIK,IFN,GMPLSEQ,GMPLDA S VALMBCK=$S(VALMCC:"",1:"R")
I $P($G(GMPLGRP),U,4)="N" W !!,"Cannot make edits to a National category." H 2 Q
I $D(^GMPL(125,"AC",+GMPLGRP)) W $C(7),!!,">>> This category belongs to at least one problem selection list!",!," CANNOT DELETE" H 2 Q
S DIR(0)="YA",DIR("B")="NO",DIR("A")="Are you sure you want to delete the entire '"_$P(GMPLGRP,U,2)_"' category? "
S DIR("?")="Enter YES to completely remove this category and all its items."
D ^DIR Q:'Y
DEL1 ; Ok, go for it ...
W !!,"Deleting category items ..."
S (GMPLSEQ,GMPLDA)=0
F S GMPLSEQ=$O(^GMPL(125.11,"C",+GMPLGRP,GMPLSEQ)) Q:'GMPLSEQ D
. F S GMPLDA=$O(^GMPL(125.11,"C",+GMPLGRP,GMPLSEQ,GMPLDA)) Q:'GMPLDA D
. . S DA(1)=+GMPLGRP,DA=GMPLDA,DIK="^GMPL(125.11,"_DA(1)_",1," D ^DIK W "."
. K ^GMPL(125.11,+GMPLGRP,1,0)
S DA=+GMPLGRP,DIK="^GMPL(125.11," D ^DIK W "."
L -^GMPL(125.11,+GMPLGRP,0) S GMPLGRP=0 K GMPLSAVE W " <done>"
D NEWGRP S:+GMPLGRP'>0 VALMBCK="Q"
Q
;
VALGRP(GMPLCAT,GMPLCODE) ; check all problems in the category for inactive SNOMED/ICD codes
; Input:
; GMPLCAT = ien from file 125.11
; GMPLCODE = Name of array where the categories & probs w/inactive codes are stored (Optional)
;
; Output:
; 1 = category has no problems with inactive codes
; 0 = category has one or more problems with inactive codes
; 0^GMPLCODE = category has one or more problems with inactive codes^array w/inactive codes
; 0^ERR = category is invalid^error message
;
; Array format (if returned):
; GMPLCODE(Category Name, Problem Sequence)=Display Text^(ICD-9/10-CM Code)^Inactive coding system (ICD,SCT,SCT/ICD)
;
I '$G(GMPLCAT) Q "0^No category selected"
N GMPLSEQ,GMPLVALC,GMPLDA,GMPDT,GMPLCNME
S GMPLVALC=1,(GMPLSEQ,GMPLDA)=0,GMPDT=$$DT^XLFDT
S GMPLCNME=$$GET1^DIQ(125.11,GMPLCAT,.01)
F S GMPLSEQ=$O(^GMPL(125.11,"C",GMPLCAT,GMPLSEQ)) Q:'GMPLSEQ D
. F S GMPLDA=$O(^GMPL(125.11,"C",GMPLCAT,GMPLSEQ,GMPLDA)) Q:'GMPLDA D
. . N GMPLICD,GMPLSCTC,GMI,GMPLX,GMPSCT,GMPICD
. . N GMPLICDS,GMPLCLBL,GMPLCPTR,GMPCSYS,GMPLDTXT
. . S (GMPSCT,GMPICD)=0
. . S GMPLX=$G(^GMPL(125.11,GMPLCAT,1,GMPLDA,0))
. . S GMPLDTXT=$P(GMPLX,U,3)
. . S GMPLICD=$P(GMPLX,U,4),GMPLSCTC=$P(GMPLX,U,5)
. . Q:'$L(GMPLICD)&('$L(GMPLSCTC)) ; no code there
. . I $L(GMPLSCTC) D
. . . I '$$STATCHK^LEXSRC2(GMPLSCTC,GMPDT,"","SCT") S GMPLVALC=0,GMPSCT=1
. . S GMPLICDS=$$CODECS^ICDEX($P(GMPLICD,"/"),80,GMPDT)
. . S GMPLCPTR=$P(GMPLICDS,U),GMPLCLBL=$P(GMPLICDS,U,2)
. . I $L(GMPLICD) D
. . . F GMI=1:1:$L(GMPLICD,"/") D
. . . . I '$$STATCHK^ICDEX($P(GMPLICD,"/",GMI),GMPDT,GMPLCPTR) S GMPLVALC=0,GMPICD=1
. . I $D(GMPLCODE),(GMPSCT!GMPICD) D
. . . S GMPCSYS=$S((GMPSCT&GMPICD):"SCT/ICD",GMPSCT:"SCT",GMPICD:"ICD",1:"")
. . . S @GMPLCODE@(GMPLCNME,GMPLSEQ)=GMPLDTXT_U_"("_GMPLCLBL_" "_GMPLICD_")"_U_GMPCSYS
. Q
I $D(GMPLCODE),('GMPLVALC) S GMPLVALC=GMPLVALC_U_GMPLCODE
Q GMPLVALC
;
VALLIST(LIST,GMPLCODE) ;check all categories in list for probs w/ inactive SNOMED/ICD codes
; Input:
; LIST = ien from file 125
; GMPLCODE = Name of array where the categories & probs w/inactive codes are stored (Optional)
;
; Output:
; 1 = list has no problems with inactive codes
; 0 = list has one or more problems with inactive codes
; 0^GMPLCODE = list has one or more problems with inactive codes^array w/inactive codes
; O^ERR = list is invalid^error message
;
; Array format (if returned):
; GMPLCODE(Category Name, Problem Sequence)=Display Text^(ICD-9/10-CM Code)^Inactive coding system (ICD,SCT,SCT/ICD)
;
N GMPLIEN,GMPLVAL
I '$G(LIST) Q 0
S GMPLCAT=0,GMPLVAL=1
F S GMPLCAT=$O(^GMPL(125,LIST,1,"B",GMPLCAT)) Q:'GMPLCAT D
. I $D(GMPLCODE) D
. . I '$$VALGRP(GMPLCAT,GMPLCODE) S GMPLVAL=0
. E I '$$VALGRP(GMPLCAT) S GMPLVAL=0
. Q
I $D(GMPLCODE) S GMPLVAL=GMPLVAL_U_GMPLCODE
Q GMPLVAL
;
ASSIGN ; assign or remove selection list to users/clinic
;
N GMPLENT,GMPLPAR,GMPJUST1,GMPLDTXT
I $D(VALMCC) D FULL^VALM1
S GMPLPAR=$$FIND1^DIC(8989.51,,"BX","ORQQPL SELECTION LIST")
I $D(GMPLPAR) S GMPLDTXT=$$GET1^DIQ(8989.51,GMPLPAR,.02),GMPLPAR=GMPLPAR_U_GMPLDTXT
F D GETENT^XPAREDIT(.GMPLENT,GMPLPAR,.GMPJUST1) Q:'GMPLENT D EDIT^XPAREDIT(GMPLENT,GMPLPAR) Q:GMPJUST1
I $D(VALMCC) S VALMBCK="R",VALMSG=$$MSG^GMPLX
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMPLBLD2 11031 printed Apr 09, 2024@21:32:53 Page 2
GMPLBLD2 ; SLC/MKB,JFR,TC -- Bld PL Selection Lists cont ;07/19/17 13:32
+1 ;;2.0;Problem List;**3,28,36,42,49**;Aug 25, 1994;Build 43
+2 ;
+3 ; External References:
+4 ; ICR 2053 $$FILE^DIE,$$UPDATE^DIE
+5 ; ICR 2336 $$GETENT,$$EDIT,$$EDITPAR^XPAREDIT
+6 ; ICR 4083 $$STATCHK^LEXSRC2
+7 ; ICR 5747 $$CODECS^ICDEX,$$STATCHK^ICDEX
+8 ; ICR 10103 $$DT^XLFDT
+9 ; ICR 10006 ^DIC
+10 ; ICR 10013 ^DIK
+11 ; ICR 10026 ^DIR
+12 ; ICR 10116 FULL^VALM1
+13 ;
NEWGRP ; Change problem groups
+1 NEW NEWGRP
DO FULL^VALM1
+2 IF $DATA(GMPLSAVE)
IF $$CKSAVE
DO SAVE
NG1 SET NEWGRP=$$GROUP("L")
if +NEWGRP'>0
GOTO NGQ
if +NEWGRP=+GMPLGRP
GOTO NGQ
+1 LOCK +^GMPL(125.11,+NEWGRP,0):1
IF '$TEST
Begin DoDot:1
+2 WRITE $CHAR(7),!!,"This category is currently being edited by another user!",!
End DoDot:1
GOTO NG1
+3 LOCK -^GMPL(125.11,+GMPLGRP,0)
SET GMPLGRP=NEWGRP
+4 DO GETLIST^GMPLBLDC
DO BUILD^GMPLBLDC("^TMP(""GMPLIST"",$J)",GMPLMODE)
DO HDR^GMPLBLDC
NGQ SET VALMBCK="R"
SET VALMSG=$$MSG^GMPLX
+1 QUIT
+2 ;
GROUP(L) ; Lookup into Problem Selection Group file #125.11
+1 ; L = "" or "L", if LAYGO is [not] allowed
NEW DIC,X,Y,DLAYGO,GMPDT
+2 SET GMPDT=$$DT^XLFDT
+3 SET DIC="^GMPL(125.11,"
SET DIC(0)="AEQMZ"_L
SET DIC("A")="Select CATEGORY NAME: "
+4 IF DIC(0)["L"
SET DLAYGO=125.11
SET DIC("DR")=".02////"_GMPDT_";.03"
SET DIC("?N","125.11")=6
+5 IF '$TEST
SET DIC("S")="I $P(^(0),U,3)'=""N"""
+6 DO ^DIC
if Y'>0
SET Y="^"
if Y'="^"
SET Y=+Y_U_Y(0)
+7 QUIT Y
+8 ;
NEWLST ; Change selection lists
+1 NEW NEWLST
DO FULL^VALM1
+2 IF $DATA(GMPLSAVE)
IF $$CKSAVE
DO SAVE
NL1 SET NEWLST=$$LIST("L")
if +NEWLST'>0
GOTO NLQ
if +NEWLST=+GMPLSLST
GOTO NLQ
+1 LOCK +^GMPL(125,+NEWLST,0):1
IF '$TEST
Begin DoDot:1
+2 WRITE $CHAR(7),!!,"This list is currently being edited by another user!",!
End DoDot:1
GOTO NL1
+3 LOCK -^GMPL(125,+GMPLSLST,0)
SET GMPLSLST=NEWLST
+4 DO GETLIST^GMPLBLD
DO BUILD^GMPLBLD("^TMP(""GMPLIST"",$J)",GMPLMODE)
DO HDR^GMPLBLD
NLQ SET VALMBCK="R"
SET VALMSG=$$MSG^GMPLX
+1 QUIT
+2 ;
LIST(L) ; Lookup into Problem Selection List file #125
+1 ; L="" or "L" if LAYGO [not] allowed
NEW DIC,X,Y,DLAYGO,GMPDT
+2 SET GMPDT=$$DT^XLFDT
+3 SET DIC="^GMPL(125,"
SET DIC(0)="AEQMZ"_L
SET DIC("A")="Select LIST NAME: "
+4 if DIC(0)["L"
SET DLAYGO=125
SET DIC("DR")=".02////"_GMPDT_";.04"
+5 DO ^DIC
if Y<0!($DATA(DTOUT))!($DATA(DUOUT))
SET Y="^"
if Y'="^"
SET Y=+Y_U_Y(0)
+6 QUIT Y
+7 ;
LAST(ROOT) ; Returns last subscript
+1 NEW I,J
SET (I,J)=""
+2 FOR
SET I=$ORDER(@(ROOT_"I)"))
if I=""
QUIT
SET J=I
+3 QUIT J
+4 ;
CKSAVE() ; Save [changes] ??
+1 NEW DIR,X,Y,TEXT
SET TEXT=$SELECT($DATA(GMPLGRP):"category",1:"list")
+2 SET DIR("A")="Save the changes to this "_TEXT_"? "
SET DIR("B")="YES"
+3 SET DIR("?",1)="Enter YES to save the changes that have been made to this "_TEXT
SET DIR("?")="before exiting it; NO will leave this "_TEXT_" unchanged."
+4 SET DIR(0)="YA"
DO ^DIR
+5 QUIT +Y
+6 ;
SAVE ; Save changes to group/list
+1 NEW GMPLQT,LABEL,DA,GMPDT
+2 SET GMPLQT=0
SET GMPDT=$$DT^XLFDT
+3 IF $DATA(GMPLGRP)
Begin DoDot:1
+4 NEW ITM,CODE
+5 SET ITM=0
+6 FOR
SET ITM=$ORDER(^TMP("GMPLIST",$JOB,ITM))
if 'ITM!(GMPLQT)
QUIT
Begin DoDot:2
+7 NEW GMI,GMPSCTC
+8 SET GMPSCTC=$PIECE(^TMP("GMPLIST",$JOB,ITM),U,5)
if '$LENGTH(GMPSCTC)
QUIT
+9 IF '$$STATCHK^LEXSRC2(GMPSCTC,GMPDT,"","SCT")
SET GMPLQT=1
QUIT
+10 SET CODE=$PIECE(^TMP("GMPLIST",$JOB,ITM),U,4)
if '$LENGTH(CODE)
QUIT
+11 FOR GMI=1:1:$LENGTH(CODE,"/")
Begin DoDot:3
+12 NEW GMPLCPTR
SET GMPLCPTR=$PIECE($$CODECS^ICDEX($PIECE(CODE,"/",GMI),80,GMPDT),U)
+13 IF '$$STATCHK^ICDEX($PIECE(CODE,"/",GMI),GMPDT,GMPLCPTR)
SET GMPLQT=1
QUIT
End DoDot:3
End DoDot:2
+14 ;no inactive codes in the category
IF 'GMPLQT
QUIT
+15 DO FULL^VALM1
+16 WRITE !!,$CHAR(7),"This Group contains problems with inactive SNOMED or ICD codes associated"
+17 WRITE !,"with them. The codes must be edited and corrected before the group can be saved."
+18 NEW DIR,DUOUT,DTOUT,DIRUT
+19 SET DIR(0)="E"
DO ^DIR
+20 SET VALMBCK="R"
SET GMPLQT=1
+21 QUIT
End DoDot:1
IF GMPLQT
QUIT
+22 ;
+23 IF '$DATA(GMPLGRP)
IF $DATA(GMPLSLST)
Begin DoDot:1
+24 NEW GRP
+25 SET GRP=0
+26 FOR
SET GRP=$ORDER(^TMP("GMPLIST",$JOB,"GRP",GRP))
if 'GRP!(GMPLQT)
QUIT
Begin DoDot:2
+27 ;no inactive codes in the GROUP
IF $$VALGRP(GRP)
QUIT
+28 SET GMPLQT=1
End DoDot:2
+29 ; all groups and problems OK
IF 'GMPLQT
QUIT
+30 DO FULL^VALM1
+31 WRITE !!,$CHAR(7),"This Selection List contains problems with inactive SNOMED or ICD codes"
+32 WRITE !,"associated with them. The codes must be edited and corrected before the"
+33 WRITE !,"list can be saved."
+34 NEW DIR,DUOUT,DTOUT,DIRUT
+35 SET DIR(0)="E"
DO ^DIR
+36 SET VALMBCK="R"
SET GMPLQT=1
+37 QUIT
End DoDot:1
IF GMPLQT
QUIT
+38 WRITE !!,"Saving ..."
+39 SET DA=0
SET LABEL=$SELECT($DATA(GMPLGRP):"SAVGRP",1:"SAVLST")
+40 FOR
SET DA=$ORDER(^TMP("GMPLIST",$JOB,DA))
if +DA'>0
QUIT
DO @LABEL
+41 KILL GMPLSAVE
if $DATA(GMPLGRP)
SET GMPSAVED=1
+42 SET VALMBCK="Q"
WRITE " done."
HANG 1
+43 QUIT
SAVGRP ; Save changes to existing group
+1 NEW I,DIK,ITEM,TMPITEM,GMPJ,GMPFDA,GMPERR,GMPSFN,GMPLTXT
+2 SET DA(1)=+GMPLGRP
SET DIK="^GMPL(125.11,"_DA(1)_",1,"
+3 SET GMPSFN="125.111"
+4 IF +DA'=DA
Begin DoDot:1
+5 ; nothing to save
if "@"[$GET(^TMP("GMPLIST",$JOB,DA))
QUIT
+6 SET TMPITEM=^TMP("GMPLIST",$JOB,DA)
DO NEW(GMPSFN,+GMPLGRP,TMPITEM)
End DoDot:1
QUIT
+7 IF "@"[$GET(^TMP("GMPLIST",$JOB,DA))
DO ^DIK
QUIT
+8 SET ITEM=$GET(^GMPL(125.11,+GMPLGRP,1,DA,0))
+9 IF ITEM'=^TMP("GMPLIST",$JOB,DA)
Begin DoDot:1
+10 FOR I=1:1:6
Begin DoDot:2
+11 SET GMPJ=$SELECT(I=1:".01",I=2:".02",I=3:".03",I=4:".04",I=5:".05",1:".06")
+12 if $PIECE(^TMP("GMPLIST",$JOB,DA),U,I)=$PIECE(ITEM,U,I)
QUIT
+13 SET GMPFDA(125.111,""_DA_","_+GMPLGRP_",",GMPJ)=$SELECT($PIECE(^TMP("GMPLIST",$JOB,DA),U,I)="":"@",1:$PIECE(^TMP("GMPLIST",$JOB,DA),U,I))
End DoDot:2
+14 DO FILE^DIE("K","GMPFDA","GMPERR")
End DoDot:1
+15 IF $DATA(GMPERR)
Begin DoDot:1
+16 SET GMPLTXT(1)="Error updating Rec #"_+GMPLGRP_", Sub-rec #"_DA_"."
+17 SET GMPLTXT(2)="Error "_GMPERR("DIERR",1)_": "_GMPERR("DIERR",1,"TEXT",1)
+18 DO EN^DDIOL(.GMPLTXT)
End DoDot:1
+19 QUIT
+20 ;
SAVLST ; Save changes to existing list
+1 NEW I,DIK,ITEM,TMPLST,GMPJ,GMPFDA,GMPERR,GMPSFN
+2 SET DA(1)=+GMPLSLST
SET DIK="^GMPL(125,"_DA(1)_",1,"
+3 SET GMPSFN="125.01"
+4 ; new link
IF +DA'=DA
Begin DoDot:1
+5 ; nothing to save
if "@"[$GET(^TMP("GMPLIST",$JOB,DA))
QUIT
+6 SET TMPLST=^TMP("GMPLIST",$JOB,DA)
DO NEW(GMPSFN,+GMPLSLST,TMPLST)
End DoDot:1
QUIT
+7 IF "@"[$GET(^TMP("GMPLIST",$JOB,DA))
DO ^DIK
QUIT
+8 SET ITEM=$GET(^GMPL(125,+GMPLSLST,1,DA,0))
+9 IF ITEM'=^TMP("GMPLIST",$JOB,DA)
Begin DoDot:1
+10 FOR I=1:1:4
Begin DoDot:2
+11 SET GMPJ=$SELECT(I=1:".01",I=2:".02",I=3:".03",1:".04")
+12 if $PIECE(^TMP("GMPLIST",$JOB,DA),U,I)=$PIECE(ITEM,U,I)
QUIT
+13 SET GMPFDA(125.01,""_DA_","_+GMPLSLST_",",GMPJ)=$SELECT($PIECE(^TMP("GMPLIST",$JOB,DA),U,I)="":"@",1:$PIECE(^TMP("GMPLIST",$JOB,DA),U,I))
End DoDot:2
+14 DO FILE^DIE("K","GMPFDA","GMPERR")
End DoDot:1
+15 IF $DATA(GMPERR)
Begin DoDot:1
+16 SET GMPLTXT(1)="Error updating Rec #"_+GMPLSLST_", Sub-rec #"_DA_"."
+17 SET GMPLTXT(2)="Error "_GMPERR("DIERR",1)_": "_GMPERR("DIERR",1,"TEXT",1)
+18 DO EN^DDIOL(.GMPLTXT)
End DoDot:1
+19 QUIT
+20 ;
NEW(GMPSFN,LIST,ITEM) ; Create new contents entry in subfile #125.01 or #125.111
+1 NEW I,GMPFDA,GMPJ,GMPNF,GMPERR,GMPFILE
+2 SET GMPFILE=$SELECT(GMPSFN="125.01":"125",1:"125.11")
+3 SET GMPNF=$SELECT(GMPSFN="125.01":4,1:6)
+4 FOR I=1:1:GMPNF
Begin DoDot:1
+5 SET GMPJ=$SELECT(I=1:".01",I=2:".02",I=3:".03",I=4:".04",I=5:".05",1:".06")
+6 SET GMPFDA(GMPSFN,"+2,"_LIST_",",GMPJ)=$PIECE(ITEM,U,I)
End DoDot:1
+7 LOCK +^GMPL(GMPFILE,LIST):5
IF '$TEST
Begin DoDot:1
+8 WRITE !,"Lock Error: error updating record #"_LIST_" in File #"_GMPFILE_"."
End DoDot:1
QUIT
+9 DO UPDATE^DIE("","GMPFDA","","GMPERR")
+10 LOCK -^GMPL(GMPFILE,LIST)
+11 QUIT
+12 ;
DELETE ; Delete problem group
+1 NEW DIR,X,Y,DA,DIK,IFN,GMPLSEQ,GMPLDA
SET VALMBCK=$SELECT(VALMCC:"",1:"R")
+2 IF $PIECE($GET(GMPLGRP),U,4)="N"
WRITE !!,"Cannot make edits to a National category."
HANG 2
QUIT
+3 IF $DATA(^GMPL(125,"AC",+GMPLGRP))
WRITE $CHAR(7),!!,">>> This category belongs to at least one problem selection list!",!," CANNOT DELETE"
HANG 2
QUIT
+4 SET DIR(0)="YA"
SET DIR("B")="NO"
SET DIR("A")="Are you sure you want to delete the entire '"_$PIECE(GMPLGRP,U,2)_"' category? "
+5 SET DIR("?")="Enter YES to completely remove this category and all its items."
+6 DO ^DIR
if 'Y
QUIT
DEL1 ; Ok, go for it ...
+1 WRITE !!,"Deleting category items ..."
+2 SET (GMPLSEQ,GMPLDA)=0
+3 FOR
SET GMPLSEQ=$ORDER(^GMPL(125.11,"C",+GMPLGRP,GMPLSEQ))
if 'GMPLSEQ
QUIT
Begin DoDot:1
+4 FOR
SET GMPLDA=$ORDER(^GMPL(125.11,"C",+GMPLGRP,GMPLSEQ,GMPLDA))
if 'GMPLDA
QUIT
Begin DoDot:2
+5 SET DA(1)=+GMPLGRP
SET DA=GMPLDA
SET DIK="^GMPL(125.11,"_DA(1)_",1,"
DO ^DIK
WRITE "."
End DoDot:2
+6 KILL ^GMPL(125.11,+GMPLGRP,1,0)
End DoDot:1
+7 SET DA=+GMPLGRP
SET DIK="^GMPL(125.11,"
DO ^DIK
WRITE "."
+8 LOCK -^GMPL(125.11,+GMPLGRP,0)
SET GMPLGRP=0
KILL GMPLSAVE
WRITE " <done>"
+9 DO NEWGRP
if +GMPLGRP'>0
SET VALMBCK="Q"
+10 QUIT
+11 ;
VALGRP(GMPLCAT,GMPLCODE) ; check all problems in the category for inactive SNOMED/ICD codes
+1 ; Input:
+2 ; GMPLCAT = ien from file 125.11
+3 ; GMPLCODE = Name of array where the categories & probs w/inactive codes are stored (Optional)
+4 ;
+5 ; Output:
+6 ; 1 = category has no problems with inactive codes
+7 ; 0 = category has one or more problems with inactive codes
+8 ; 0^GMPLCODE = category has one or more problems with inactive codes^array w/inactive codes
+9 ; 0^ERR = category is invalid^error message
+10 ;
+11 ; Array format (if returned):
+12 ; GMPLCODE(Category Name, Problem Sequence)=Display Text^(ICD-9/10-CM Code)^Inactive coding system (ICD,SCT,SCT/ICD)
+13 ;
+14 IF '$GET(GMPLCAT)
QUIT "0^No category selected"
+15 NEW GMPLSEQ,GMPLVALC,GMPLDA,GMPDT,GMPLCNME
+16 SET GMPLVALC=1
SET (GMPLSEQ,GMPLDA)=0
SET GMPDT=$$DT^XLFDT
+17 SET GMPLCNME=$$GET1^DIQ(125.11,GMPLCAT,.01)
+18 FOR
SET GMPLSEQ=$ORDER(^GMPL(125.11,"C",GMPLCAT,GMPLSEQ))
if 'GMPLSEQ
QUIT
Begin DoDot:1
+19 FOR
SET GMPLDA=$ORDER(^GMPL(125.11,"C",GMPLCAT,GMPLSEQ,GMPLDA))
if 'GMPLDA
QUIT
Begin DoDot:2
+20 NEW GMPLICD,GMPLSCTC,GMI,GMPLX,GMPSCT,GMPICD
+21 NEW GMPLICDS,GMPLCLBL,GMPLCPTR,GMPCSYS,GMPLDTXT
+22 SET (GMPSCT,GMPICD)=0
+23 SET GMPLX=$GET(^GMPL(125.11,GMPLCAT,1,GMPLDA,0))
+24 SET GMPLDTXT=$PIECE(GMPLX,U,3)
+25 SET GMPLICD=$PIECE(GMPLX,U,4)
SET GMPLSCTC=$PIECE(GMPLX,U,5)
+26 ; no code there
if '$LENGTH(GMPLICD)&('$LENGTH(GMPLSCTC))
QUIT
+27 IF $LENGTH(GMPLSCTC)
Begin DoDot:3
+28 IF '$$STATCHK^LEXSRC2(GMPLSCTC,GMPDT,"","SCT")
SET GMPLVALC=0
SET GMPSCT=1
End DoDot:3
+29 SET GMPLICDS=$$CODECS^ICDEX($PIECE(GMPLICD,"/"),80,GMPDT)
+30 SET GMPLCPTR=$PIECE(GMPLICDS,U)
SET GMPLCLBL=$PIECE(GMPLICDS,U,2)
+31 IF $LENGTH(GMPLICD)
Begin DoDot:3
+32 FOR GMI=1:1:$LENGTH(GMPLICD,"/")
Begin DoDot:4
+33 IF '$$STATCHK^ICDEX($PIECE(GMPLICD,"/",GMI),GMPDT,GMPLCPTR)
SET GMPLVALC=0
SET GMPICD=1
End DoDot:4
End DoDot:3
+34 IF $DATA(GMPLCODE)
IF (GMPSCT!GMPICD)
Begin DoDot:3
+35 SET GMPCSYS=$SELECT((GMPSCT&GMPICD):"SCT/ICD",GMPSCT:"SCT",GMPICD:"ICD",1:"")
+36 SET @GMPLCODE@(GMPLCNME,GMPLSEQ)=GMPLDTXT_U_"("_GMPLCLBL_" "_GMPLICD_")"_U_GMPCSYS
End DoDot:3
End DoDot:2
+37 QUIT
End DoDot:1
+38 IF $DATA(GMPLCODE)
IF ('GMPLVALC)
SET GMPLVALC=GMPLVALC_U_GMPLCODE
+39 QUIT GMPLVALC
+40 ;
VALLIST(LIST,GMPLCODE) ;check all categories in list for probs w/ inactive SNOMED/ICD codes
+1 ; Input:
+2 ; LIST = ien from file 125
+3 ; GMPLCODE = Name of array where the categories & probs w/inactive codes are stored (Optional)
+4 ;
+5 ; Output:
+6 ; 1 = list has no problems with inactive codes
+7 ; 0 = list has one or more problems with inactive codes
+8 ; 0^GMPLCODE = list has one or more problems with inactive codes^array w/inactive codes
+9 ; O^ERR = list is invalid^error message
+10 ;
+11 ; Array format (if returned):
+12 ; GMPLCODE(Category Name, Problem Sequence)=Display Text^(ICD-9/10-CM Code)^Inactive coding system (ICD,SCT,SCT/ICD)
+13 ;
+14 NEW GMPLIEN,GMPLVAL
+15 IF '$GET(LIST)
QUIT 0
+16 SET GMPLCAT=0
SET GMPLVAL=1
+17 FOR
SET GMPLCAT=$ORDER(^GMPL(125,LIST,1,"B",GMPLCAT))
if 'GMPLCAT
QUIT
Begin DoDot:1
+18 IF $DATA(GMPLCODE)
Begin DoDot:2
+19 IF '$$VALGRP(GMPLCAT,GMPLCODE)
SET GMPLVAL=0
End DoDot:2
+20 IF '$TEST
IF '$$VALGRP(GMPLCAT)
SET GMPLVAL=0
+21 QUIT
End DoDot:1
+22 IF $DATA(GMPLCODE)
SET GMPLVAL=GMPLVAL_U_GMPLCODE
+23 QUIT GMPLVAL
+24 ;
ASSIGN ; assign or remove selection list to users/clinic
+1 ;
+2 NEW GMPLENT,GMPLPAR,GMPJUST1,GMPLDTXT
+3 IF $DATA(VALMCC)
DO FULL^VALM1
+4 SET GMPLPAR=$$FIND1^DIC(8989.51,,"BX","ORQQPL SELECTION LIST")
+5 IF $DATA(GMPLPAR)
SET GMPLDTXT=$$GET1^DIQ(8989.51,GMPLPAR,.02)
SET GMPLPAR=GMPLPAR_U_GMPLDTXT
+6 FOR
DO GETENT^XPAREDIT(.GMPLENT,GMPLPAR,.GMPJUST1)
if 'GMPLENT
QUIT
DO EDIT^XPAREDIT(GMPLENT,GMPLPAR)
if GMPJUST1
QUIT
+7 IF $DATA(VALMCC)
SET VALMBCK="R"
SET VALMSG=$$MSG^GMPLX
+8 QUIT
