GMPLBLD2 ; SLC/MKB,JFR -- Bld PL Selection Lists cont ;09/21/11 16:33
;;2.0;Problem List;**3,28,36**;Aug 25, 1994;Build 65
;
; This routine invokes IA #3991
;
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 ; L = "" or "L", if LAYGO is [not] allowed
S DIC="^GMPL(125.11,",DIC(0)="AEQMZ"_L,DIC("A")="Select CATEGORY NAME: "
S:DIC(0)["L" DLAYGO=125.11
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 ; L="" or "L" if LAYGO [not] allowed
S DIC="^GMPL(125,",DIC(0)="AEQMZ"_L,DIC("A")="Select LIST NAME: "
S:DIC(0)["L" DLAYGO=125
D ^DIC S:Y'>0 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
S GMPLQT=0
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
.. S CODE=$P(^TMP("GMPLIST",$J,ITM),U,4) Q:'$L(CODE)
.. F GMI=1:1:$L(CODE,"/") I '$$STATCHK^ICDAPIU($P(CODE,"/",GMI),DT) 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 ICD9 codes associated with them."
. W !,"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 ICD9 codes associated with"
. W !,"them. The codes must be edited and corrected before the 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 DIK,DIE,DR,ITEM,TMPITEM
S DIK="^GMPL(125.12,"
I +DA'=DA D Q
. Q:"@"[$G(^TMP("GMPLIST",$J,DA)) ; nothing to save
. S TMPITEM=^TMP("GMPLIST",$J,DA) D NEW(DIK,+GMPLGRP,TMPITEM)
I "@"[$G(^TMP("GMPLIST",$J,DA)) D ^DIK Q
S ITEM=$P($G(^GMPL(125.12,DA,0)),U,2,7)
I ITEM'=^TMP("GMPLIST",$J,DA) D
. S DR="",DIE=DIK
. F I=1:1:6 D
.. S:$P(^TMP("GMPLIST",$J,DA),U,I)'=$P(ITEM,U,I) DR=DR_";"_I_"////"_$S($P(^TMP("GMPLIST",$J,DA),U,I)="":"@",1:$P(^TMP("GMPLIST",$J,DA),U,I))
. S:$E(DR)=";" DR=$E(DR,2,999) D ^DIE
Q
;
SAVLST ; Save changes to existing list
N DIK,DIE,DR,ITEM,TMPLST
S DIK="^GMPL(125.1,"
I +DA'=DA D Q ; new link
. Q:"@"[$G(^TMP("GMPLIST",$J,DA)) ; nothing to save
. S TMPLST=^TMP("GMPLIST",$J,DA) D NEW(DIK,+GMPLSLST,TMPLST)
I "@"[$G(^TMP("GMPLIST",$J,DA)) D ^DIK Q
S ITEM=$P($G(^GMPL(125.1,DA,0)),U,2,5)
I ITEM'=^TMP("GMPLIST",$J,DA) D
. S DR="",DIE=DIK
. F I=1,2,3,4 D
.. S:$P(^TMP("GMPLIST",$J,DA),U,I)'=$P(ITEM,U,I) DR=DR_";"_I_"////"_$S($P(^TMP("GMPLIST",$J,DA),U,I)="":"@",1:$P(^TMP("GMPLIST",$J,DA),U,I))
. S:$E(DR)=";" DR=$E(DR,2,999) D ^DIE
Q
;
NEW(DIK,LIST,ITEM) ; Create new entry in Contents file #125.1 or #125.12
N I,HDR,LAST,TOTAL,DA
S HDR=$G(@(DIK_"0)")),LAST=$P(HDR,U,3),TOTAL=$P(HDR,U,4)
F I=(LAST+1):1 Q:'$D(@(DIK_"I,0)"))
S DA=I,@(DIK_"DA,0)")=LIST_U_ITEM
S $P(@(DIK_"0)"),U,3,4)=DA_U_(TOTAL+1)
D IX1^DIK ; set Xrefs
Q
;
DELETE ; Delete problem group
N DIR,X,Y,DA,DIK,IFN S VALMBCK=$S(VALMCC:"",1:"R")
I $D(^GMPL(125.1,"G",+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 ..."
F IFN=0:0 S IFN=$O(^GMPL(125.12,"B",+GMPLGRP,IFN)) Q:IFN'>0 S DA=IFN,DIK="^GMPL(125.12," D ^DIK W "."
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) ; check all problems in the category for inactive codes
; Input:
; GMPLCAT = ien from file 125.11
;
; Output:
; 1 = category has no problems with inactive codes
; 0 = category has one or more problems with inactive codes
; O^ERR = category is invalid^error message
;
I '$G(GMPLCAT) Q "0^No category selected"
N PROB,GMPLVALC
S GMPLVALC=1,PROB=0
F S PROB=$O(^GMPL(125.12,"B",GMPLCAT,PROB)) Q:'PROB!('GMPLVALC) D
. N GMPLCOD,GMI
. S GMPLCOD=$P(^GMPL(125.12,PROB,0),U,5)
. Q:'$L(GMPLCOD) ; no code there
. F GMI=1:1:$L(GMPLCOD,"/") I '$$STATCHK^ICDAPIU($P(GMPLCOD,"/",GMI),DT) S GMPLVALC=0
. Q
Q GMPLVALC
;
VALLIST(LIST) ;check all categories in list for probs w/ inactive codes
; Input:
; LIST = ien from file 125
;
; Output:
; 1 = list has no problems with inactive codes
; 0 = list has one or more problems with inactive codes
; O^ERR = list is invalid^error message
;
N GMPLIEN,GMPLVAL
I '$G(LIST) Q 0
S GMPLIEN=0,GMPLVAL=1
F S GMPLIEN=$O(^GMPL(125.1,"B",LIST,GMPLIEN)) Q:'GMPLIEN!('GMPLVAL) D
. N GMPLCAT
. S GMPLCAT=$P(^GMPL(125.1,GMPLIEN,0),U,3) I 'GMPLCAT Q
. I '$$VALGRP(GMPLCAT) S GMPLVAL=0
. Q
Q GMPLVAL
;
ASSIGN ; allow lookup of PROB SEL LIST and assign to users
;
N DIC,X,Y,DUOUT,DTOUT,GMPLSLST
S DIC="^GMPL(125,",DIC(0)="AEQMZ",DIC("A")="Select LIST NAME: "
D ^DIC
Q:$D(DTOUT)!($D(DUOUT))
Q:Y<0
I '$$VALLIST(+Y) D G ASSIGN
. W !!,$C(7),"This Selection List contains problems with inactive ICD9 codes associated with"
. W !,"them. The codes must be edited and corrected before the list can be assigned to",!,"users.",!!
;
S GMPLSLST=+Y
D USERS^GMPLBLD3("1")
Q
GMPLBLD2 ; SLC/MKB,JFR -- Bld PL Selection Lists cont ;09/21/11 16:33
+1 ;;2.0;Problem List;**3,28,36**;Aug 25, 1994;Build 65
+2 ;
+3 ; This routine invokes IA #3991
+4 ;
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
+2 SET DIC="^GMPL(125.11,"
SET DIC(0)="AEQMZ"_L
SET DIC("A")="Select CATEGORY NAME: "
+3 IF DIC(0)["L"
SET DLAYGO=125.11
+4 DO ^DIC
IF Y'>0
SET Y="^"
IF Y'="^"
SET Y=+Y_U_Y(0)
+5 QUIT Y
+6 ;
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
+2 SET DIC="^GMPL(125,"
SET DIC(0)="AEQMZ"_L
SET DIC("A")="Select LIST NAME: "
+3 IF DIC(0)["L"
SET DLAYGO=125
+4 DO ^DIC
IF Y'>0
SET Y="^"
IF Y'="^"
SET Y=+Y_U_Y(0)
+5 QUIT Y
+6 ;
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
+2 SET GMPLQT=0
+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
+8 SET CODE=$PIECE(^TMP("GMPLIST",$JOB,ITM),U,4)
IF '$LENGTH(CODE)
QUIT
+9 FOR GMI=1:1:$LENGTH(CODE,"/")
IF '$$STATCHK^ICDAPIU($PIECE(CODE,"/",GMI),DT)
SET GMPLQT=1
QUIT
End DoDot:2
+10 ;no inactive codes in the category
IF 'GMPLQT
QUIT
+11 DO FULL^VALM1
+12 WRITE !!,$CHAR(7),"This Group contains problems with inactive ICD9 codes associated with them."
+13 WRITE !,"The codes must be edited and corrected before the group can be saved."
+14 NEW DIR,DUOUT,DTOUT,DIRUT
+15 SET DIR(0)="E"
DO ^DIR
+16 SET VALMBCK="R"
SET GMPLQT=1
+17 QUIT
End DoDot:1
IF GMPLQT
QUIT
+18 ;
+19 IF '$DATA(GMPLGRP)
IF $DATA(GMPLSLST)
Begin DoDot:1
+20 NEW GRP
+21 SET GRP=0
+22 FOR
SET GRP=$ORDER(^TMP("GMPLIST",$JOB,"GRP",GRP))
IF 'GRP!(GMPLQT)
QUIT
Begin DoDot:2
+23 ;no inactive codes in the GROUP
IF $$VALGRP(GRP)
QUIT
+24 SET GMPLQT=1
End DoDot:2
+25 ; all groups and problems OK
IF 'GMPLQT
QUIT
+26 DO FULL^VALM1
+27 WRITE !!,$CHAR(7),"This Selection List contains problems with inactive ICD9 codes associated with"
+28 WRITE !,"them. The codes must be edited and corrected before the list can be saved."
+29 NEW DIR,DUOUT,DTOUT,DIRUT
+30 SET DIR(0)="E"
DO ^DIR
+31 SET VALMBCK="R"
SET GMPLQT=1
+32 QUIT
End DoDot:1
IF GMPLQT
QUIT
+33 WRITE !!,"Saving ..."
+34 SET DA=0
SET LABEL=$SELECT($DATA(GMPLGRP):"SAVGRP",1:"SAVLST")
+35 FOR
SET DA=$ORDER(^TMP("GMPLIST",$JOB,DA))
IF +DA'>0
QUIT
DO @LABEL
+36 KILL GMPLSAVE
IF $DATA(GMPLGRP)
SET GMPSAVED=1
+37 SET VALMBCK="Q"
WRITE " done."
HANG 1
+38 QUIT
SAVGRP ; Save changes to existing group
+1 NEW DIK,DIE,DR,ITEM,TMPITEM
+2 SET DIK="^GMPL(125.12,"
+3 IF +DA'=DA
Begin DoDot:1
+4 ; nothing to save
IF "@"[$GET(^TMP("GMPLIST",$JOB,DA))
QUIT
+5 SET TMPITEM=^TMP("GMPLIST",$JOB,DA)
DO NEW(DIK,+GMPLGRP,TMPITEM)
End DoDot:1
QUIT
+6 IF "@"[$GET(^TMP("GMPLIST",$JOB,DA))
DO ^DIK
QUIT
+7 SET ITEM=$PIECE($GET(^GMPL(125.12,DA,0)),U,2,7)
+8 IF ITEM'=^TMP("GMPLIST",$JOB,DA)
Begin DoDot:1
+9 SET DR=""
SET DIE=DIK
+10 FOR I=1:1:6
Begin DoDot:2
+11 IF $PIECE(^TMP("GMPLIST",$JOB,DA),U,I)'=$PIECE(ITEM,U,I)
SET DR=DR_";"_I_"////"_$SELECT($PIECE(^TMP("GMPLIST",$JOB,DA),U,I)="":"@",1:$PIECE(^TMP("GMPLIST",$JOB,DA),U,I))
End DoDot:2
+12 IF $EXTRACT(DR)=";"
SET DR=$EXTRACT(DR,2,999)
DO ^DIE
End DoDot:1
+13 QUIT
+14 ;
SAVLST ; Save changes to existing list
+1 NEW DIK,DIE,DR,ITEM,TMPLST
+2 SET DIK="^GMPL(125.1,"
+3 ; new link
IF +DA'=DA
Begin DoDot:1
+4 ; nothing to save
IF "@"[$GET(^TMP("GMPLIST",$JOB,DA))
QUIT
+5 SET TMPLST=^TMP("GMPLIST",$JOB,DA)
DO NEW(DIK,+GMPLSLST,TMPLST)
End DoDot:1
QUIT
+6 IF "@"[$GET(^TMP("GMPLIST",$JOB,DA))
DO ^DIK
QUIT
+7 SET ITEM=$PIECE($GET(^GMPL(125.1,DA,0)),U,2,5)
+8 IF ITEM'=^TMP("GMPLIST",$JOB,DA)
Begin DoDot:1
+9 SET DR=""
SET DIE=DIK
+10 FOR I=1,2,3,4
Begin DoDot:2
+11 IF $PIECE(^TMP("GMPLIST",$JOB,DA),U,I)'=$PIECE(ITEM,U,I)
SET DR=DR_";"_I_"////"_$SELECT($PIECE(^TMP("GMPLIST",$JOB,DA),U,I)="":"@",1:$PIECE(^TMP("GMPLIST",$JOB,DA),U,I))
End DoDot:2
+12 IF $EXTRACT(DR)=";"
SET DR=$EXTRACT(DR,2,999)
DO ^DIE
End DoDot:1
+13 QUIT
+14 ;
NEW(DIK,LIST,ITEM) ; Create new entry in Contents file #125.1 or #125.12
+1 NEW I,HDR,LAST,TOTAL,DA
+2 SET HDR=$GET(@(DIK_"0)"))
SET LAST=$PIECE(HDR,U,3)
SET TOTAL=$PIECE(HDR,U,4)
+3 FOR I=(LAST+1):1
IF '$DATA(@(DIK_"I,0)"))
QUIT
+4 SET DA=I
SET @(DIK_"DA,0)")=LIST_U_ITEM
+5 SET $PIECE(@(DIK_"0)"),U,3,4)=DA_U_(TOTAL+1)
+6 ; set Xrefs
DO IX1^DIK
+7 QUIT
+8 ;
DELETE ; Delete problem group
+1 NEW DIR,X,Y,DA,DIK,IFN
SET VALMBCK=$SELECT(VALMCC:"",1:"R")
+2 IF $DATA(^GMPL(125.1,"G",+GMPLGRP))
WRITE $CHAR(7),!!,">>> This category belongs to at least one problem selection list!",!," CANNOT DELETE"
HANG 2
QUIT
+3 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? "
+4 SET DIR("?")="Enter YES to completely remove this category and all its items."
+5 DO ^DIR
IF 'Y
QUIT
DEL1 ; Ok, go for it ...
+1 WRITE !!,"Deleting category items ..."
+2 FOR IFN=0:0
SET IFN=$ORDER(^GMPL(125.12,"B",+GMPLGRP,IFN))
IF IFN'>0
QUIT
SET DA=IFN
SET DIK="^GMPL(125.12,"
DO ^DIK
WRITE "."
+3 SET DA=+GMPLGRP
SET DIK="^GMPL(125.11,"
DO ^DIK
WRITE "."
+4 LOCK -^GMPL(125.11,+GMPLGRP,0)
SET GMPLGRP=0
KILL GMPLSAVE
WRITE " <done>"
+5 DO NEWGRP
IF +GMPLGRP'>0
SET VALMBCK="Q"
+6 QUIT
+7 ;
VALGRP(GMPLCAT) ; check all problems in the category for inactive codes
+1 ; Input:
+2 ; GMPLCAT = ien from file 125.11
+3 ;
+4 ; Output:
+5 ; 1 = category has no problems with inactive codes
+6 ; 0 = category has one or more problems with inactive codes
+7 ; O^ERR = category is invalid^error message
+8 ;
+9 IF '$GET(GMPLCAT)
QUIT "0^No category selected"
+10 NEW PROB,GMPLVALC
+11 SET GMPLVALC=1
SET PROB=0
+12 FOR
SET PROB=$ORDER(^GMPL(125.12,"B",GMPLCAT,PROB))
IF 'PROB!('GMPLVALC)
QUIT
Begin DoDot:1
+13 NEW GMPLCOD,GMI
+14 SET GMPLCOD=$PIECE(^GMPL(125.12,PROB,0),U,5)
+15 ; no code there
IF '$LENGTH(GMPLCOD)
QUIT
+16 FOR GMI=1:1:$LENGTH(GMPLCOD,"/")
IF '$$STATCHK^ICDAPIU($PIECE(GMPLCOD,"/",GMI),DT)
SET GMPLVALC=0
+17 QUIT
End DoDot:1
+18 QUIT GMPLVALC
+19 ;
VALLIST(LIST) ;check all categories in list for probs w/ inactive codes
+1 ; Input:
+2 ; LIST = ien from file 125
+3 ;
+4 ; Output:
+5 ; 1 = list has no problems with inactive codes
+6 ; 0 = list has one or more problems with inactive codes
+7 ; O^ERR = list is invalid^error message
+8 ;
+9 NEW GMPLIEN,GMPLVAL
+10 IF '$GET(LIST)
QUIT 0
+11 SET GMPLIEN=0
SET GMPLVAL=1
+12 FOR
SET GMPLIEN=$ORDER(^GMPL(125.1,"B",LIST,GMPLIEN))
IF 'GMPLIEN!('GMPLVAL)
QUIT
Begin DoDot:1
+13 NEW GMPLCAT
+14 SET GMPLCAT=$PIECE(^GMPL(125.1,GMPLIEN,0),U,3)
IF 'GMPLCAT
QUIT
+15 IF '$$VALGRP(GMPLCAT)
SET GMPLVAL=0
+16 QUIT
End DoDot:1
+17 QUIT GMPLVAL
+18 ;
ASSIGN ; allow lookup of PROB SEL LIST and assign to users
+1 ;
+2 NEW DIC,X,Y,DUOUT,DTOUT,GMPLSLST
+3 SET DIC="^GMPL(125,"
SET DIC(0)="AEQMZ"
SET DIC("A")="Select LIST NAME: "
+4 DO ^DIC
+5 IF $DATA(DTOUT)!($DATA(DUOUT))
QUIT
+6 IF Y<0
QUIT
+7 IF '$$VALLIST(+Y)
Begin DoDot:1
+8 WRITE !!,$CHAR(7),"This Selection List contains problems with inactive ICD9 codes associated with"
+9 WRITE !,"them. The codes must be edited and corrected before the list can be assigned to",!,"users.",!!
End DoDot:1
GOTO ASSIGN
+10 ;
+11 SET GMPLSLST=+Y
+12 DO USERS^GMPLBLD3("1")
+13 QUIT
