- 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
