Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: GMPLBLD2

GMPLBLD2.m

Go to the documentation of this file. 
  1. 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
  1.  ;
  1.  ; External References:
  1.  ;   ICR  2053   $$FILE^DIE,$$UPDATE^DIE
  1.  ;   ICR  2336   $$GETENT,$$EDIT,$$EDITPAR^XPAREDIT
  1.  ;   ICR  4083   $$STATCHK^LEXSRC2
  1.  ;   ICR  5747   $$CODECS^ICDEX,$$STATCHK^ICDEX
  1.  ;   ICR  10103  $$DT^XLFDT
  1.  ;   ICR  10006  ^DIC
  1.  ;   ICR  10013  ^DIK
  1.  ;   ICR  10026  ^DIR
  1.  ;   ICR  10116  FULL^VALM1
  1.  ;
  1. NEWGRP ; Change problem groups
  1.  N NEWGRP D FULL^VALM1
  1.  I $D(GMPLSAVE),$$CKSAVE D SAVE
  1. NG1 S NEWGRP=$$GROUP("L") G:+NEWGRP'>0 NGQ G:+NEWGRP=+GMPLGRP NGQ
  1.  L +^GMPL(125.11,+NEWGRP,0):1 I '$T D  G NG1
  1.  . W $C(7),!!,"This category is currently being edited by another user!",!
  1.  L -^GMPL(125.11,+GMPLGRP,0) S GMPLGRP=NEWGRP
  1.  D GETLIST^GMPLBLDC,BUILD^GMPLBLDC("^TMP(""GMPLIST"",$J)",GMPLMODE),HDR^GMPLBLDC
  1. NGQ S VALMBCK="R",VALMSG=$$MSG^GMPLX
  1.  Q
  1.  ;
  1. GROUP(L) ; Lookup into Problem Selection Group file #125.11
  1.  N DIC,X,Y,DLAYGO,GMPDT ; L = "" or "L", if LAYGO is [not] allowed
  1.  S GMPDT=$$DT^XLFDT
  1.  S DIC="^GMPL(125.11,",DIC(0)="AEQMZ"_L,DIC("A")="Select CATEGORY NAME: "
  1.  I DIC(0)["L" S DLAYGO=125.11,DIC("DR")=".02////"_GMPDT_";.03",DIC("?N","125.11")=6
  1.  E  S DIC("S")="I $P(^(0),U,3)'=""N"""
  1.  D ^DIC S:Y'>0 Y="^" S:Y'="^" Y=+Y_U_Y(0)
  1.  Q Y
  1.  ;
  1. NEWLST ; Change selection lists
  1.  N NEWLST D FULL^VALM1
  1.  I $D(GMPLSAVE),$$CKSAVE D SAVE
  1. NL1 S NEWLST=$$LIST("L") G:+NEWLST'>0 NLQ G:+NEWLST=+GMPLSLST NLQ
  1.  L +^GMPL(125,+NEWLST,0):1 I '$T D  G NL1
  1.  . W $C(7),!!,"This list is currently being edited by another user!",!
  1.  L -^GMPL(125,+GMPLSLST,0) S GMPLSLST=NEWLST
  1.  D GETLIST^GMPLBLD,BUILD^GMPLBLD("^TMP(""GMPLIST"",$J)",GMPLMODE),HDR^GMPLBLD
  1. NLQ S VALMBCK="R",VALMSG=$$MSG^GMPLX
  1.  Q
  1.  ;
  1. LIST(L) ; Lookup into Problem Selection List file #125
  1.  N DIC,X,Y,DLAYGO,GMPDT ; L="" or "L" if LAYGO [not] allowed
  1.  S GMPDT=$$DT^XLFDT
  1.  S DIC="^GMPL(125,",DIC(0)="AEQMZ"_L,DIC("A")="Select LIST NAME: "
  1.  S:DIC(0)["L" DLAYGO=125,DIC("DR")=".02////"_GMPDT_";.04"
  1.  D ^DIC S:Y<0!($D(DTOUT))!($D(DUOUT)) Y="^" S:Y'="^" Y=+Y_U_Y(0)
  1.  Q Y
  1.  ;
  1. LAST(ROOT) ; Returns last subscript
  1.  N I,J S (I,J)=""
  1.  F  S I=$O(@(ROOT_"I)")) Q:I=""  S J=I
  1.  Q J
  1.  ;
  1. CKSAVE() ; Save [changes] ??
  1.  N DIR,X,Y,TEXT S TEXT=$S($D(GMPLGRP):"category",1:"list")
  1.  S DIR("A")="Save the changes to this "_TEXT_"? ",DIR("B")="YES"
  1.  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."
  1.  S DIR(0)="YA" D ^DIR
  1.  Q +Y
  1.  ;
  1. SAVE ; Save changes to group/list
  1.  N GMPLQT,LABEL,DA,GMPDT
  1.  S GMPLQT=0,GMPDT=$$DT^XLFDT
  1.  I $D(GMPLGRP) D  I GMPLQT Q
  1.  . N ITM,CODE
  1.  . S ITM=0
  1.  . F  S ITM=$O(^TMP("GMPLIST",$J,ITM)) Q:'ITM!(GMPLQT)  D
  1.  .. N GMI,GMPSCTC
  1.  .. S GMPSCTC=$P(^TMP("GMPLIST",$J,ITM),U,5) Q:'$L(GMPSCTC)
  1.  .. I '$$STATCHK^LEXSRC2(GMPSCTC,GMPDT,"","SCT") S GMPLQT=1 Q
  1.  .. S CODE=$P(^TMP("GMPLIST",$J,ITM),U,4) Q:'$L(CODE)
  1.  .. F GMI=1:1:$L(CODE,"/") D
  1.  ... N GMPLCPTR S GMPLCPTR=$P($$CODECS^ICDEX($P(CODE,"/",GMI),80,GMPDT),U)
  1.  ... I '$$STATCHK^ICDEX($P(CODE,"/",GMI),GMPDT,GMPLCPTR) S GMPLQT=1 Q
  1.  . I 'GMPLQT Q  ;no inactive codes in the category
  1.  . D FULL^VALM1
  1.  . W !!,$C(7),"This Group contains problems with inactive SNOMED or ICD codes associated"
  1.  . W !,"with them. The codes must be edited and corrected before the group can be saved."
  1.  . N DIR,DUOUT,DTOUT,DIRUT
  1.  . S DIR(0)="E" D ^DIR
  1.  . S VALMBCK="R",GMPLQT=1
  1.  . Q
  1.  ;
  1.  I '$D(GMPLGRP),$D(GMPLSLST) D  I GMPLQT Q
  1.  . N GRP
  1.  . S GRP=0
  1.  . F  S GRP=$O(^TMP("GMPLIST",$J,"GRP",GRP)) Q:'GRP!(GMPLQT)  D
  1.  .. I $$VALGRP(GRP) Q  ;no inactive codes in the GROUP
  1.  .. S GMPLQT=1
  1.  . I 'GMPLQT Q  ; all groups and problems OK
  1.  . D FULL^VALM1
  1.  . W !!,$C(7),"This Selection List contains problems with inactive SNOMED or ICD codes"
  1.  . W !,"associated with them. The codes must be edited and corrected before the"
  1.  . W !,"list can be saved."
  1.  . N DIR,DUOUT,DTOUT,DIRUT
  1.  . S DIR(0)="E" D ^DIR
  1.  . S VALMBCK="R",GMPLQT=1
  1.  . Q
  1.  W !!,"Saving ..."
  1.  S DA=0,LABEL=$S($D(GMPLGRP):"SAVGRP",1:"SAVLST")
  1.  F  S DA=$O(^TMP("GMPLIST",$J,DA)) Q:+DA'>0  D @LABEL
  1.  K GMPLSAVE S:$D(GMPLGRP) GMPSAVED=1
  1.  S VALMBCK="Q" W " done." H 1
  1.  Q
  1. SAVGRP ; Save changes to existing group
  1.  N I,DIK,ITEM,TMPITEM,GMPJ,GMPFDA,GMPERR,GMPSFN,GMPLTXT
  1.  S DA(1)=+GMPLGRP,DIK="^GMPL(125.11,"_DA(1)_",1,"
  1.  S GMPSFN="125.111"
  1.  I +DA'=DA D  Q
  1.  . Q:"@"[$G(^TMP("GMPLIST",$J,DA))  ; nothing to save
  1.  . S TMPITEM=^TMP("GMPLIST",$J,DA) D NEW(GMPSFN,+GMPLGRP,TMPITEM)
  1.  I "@"[$G(^TMP("GMPLIST",$J,DA)) D ^DIK Q
  1.  S ITEM=$G(^GMPL(125.11,+GMPLGRP,1,DA,0))
  1.  I ITEM'=^TMP("GMPLIST",$J,DA) D
  1.  . F I=1:1:6 D
  1.  .. S GMPJ=$S(I=1:".01",I=2:".02",I=3:".03",I=4:".04",I=5:".05",1:".06")
  1.  .. Q:$P(^TMP("GMPLIST",$J,DA),U,I)=$P(ITEM,U,I)
  1.  .. S GMPFDA(125.111,""_DA_","_+GMPLGRP_",",GMPJ)=$S($P(^TMP("GMPLIST",$J,DA),U,I)="":"@",1:$P(^TMP("GMPLIST",$J,DA),U,I))
  1.  . D FILE^DIE("K","GMPFDA","GMPERR")
  1.  I $D(GMPERR) D
  1.  . S GMPLTXT(1)="Error updating Rec #"_+GMPLGRP_", Sub-rec #"_DA_"."
  1.  . S GMPLTXT(2)="Error "_GMPERR("DIERR",1)_": "_GMPERR("DIERR",1,"TEXT",1)
  1.  . D EN^DDIOL(.GMPLTXT)
  1.  Q
  1.  ;
  1. SAVLST ; Save changes to existing list
  1.  N I,DIK,ITEM,TMPLST,GMPJ,GMPFDA,GMPERR,GMPSFN
  1.  S DA(1)=+GMPLSLST,DIK="^GMPL(125,"_DA(1)_",1,"
  1.  S GMPSFN="125.01"
  1.  I +DA'=DA D  Q  ; new link
  1.  . Q:"@"[$G(^TMP("GMPLIST",$J,DA))  ; nothing to save
  1.  . S TMPLST=^TMP("GMPLIST",$J,DA) D NEW(GMPSFN,+GMPLSLST,TMPLST)
  1.  I "@"[$G(^TMP("GMPLIST",$J,DA)) D ^DIK Q
  1.  S ITEM=$G(^GMPL(125,+GMPLSLST,1,DA,0))
  1.  I ITEM'=^TMP("GMPLIST",$J,DA) D
  1.  . F I=1:1:4 D
  1.  .. S GMPJ=$S(I=1:".01",I=2:".02",I=3:".03",1:".04")
  1.  .. Q:$P(^TMP("GMPLIST",$J,DA),U,I)=$P(ITEM,U,I)
  1.  .. S GMPFDA(125.01,""_DA_","_+GMPLSLST_",",GMPJ)=$S($P(^TMP("GMPLIST",$J,DA),U,I)="":"@",1:$P(^TMP("GMPLIST",$J,DA),U,I))
  1.  . D FILE^DIE("K","GMPFDA","GMPERR")
  1.  I $D(GMPERR) D
  1.  . S GMPLTXT(1)="Error updating Rec #"_+GMPLSLST_", Sub-rec #"_DA_"."
  1.  . S GMPLTXT(2)="Error "_GMPERR("DIERR",1)_": "_GMPERR("DIERR",1,"TEXT",1)
  1.  . D EN^DDIOL(.GMPLTXT)
  1.  Q
  1.  ;
  1. NEW(GMPSFN,LIST,ITEM) ; Create new contents entry in subfile #125.01 or #125.111
  1.  N I,GMPFDA,GMPJ,GMPNF,GMPERR,GMPFILE
  1.  S GMPFILE=$S(GMPSFN="125.01":"125",1:"125.11")
  1.  S GMPNF=$S(GMPSFN="125.01":4,1:6)
  1.  F I=1:1:GMPNF D
  1.  . S GMPJ=$S(I=1:".01",I=2:".02",I=3:".03",I=4:".04",I=5:".05",1:".06")
  1.  . S GMPFDA(GMPSFN,"+2,"_LIST_",",GMPJ)=$P(ITEM,U,I)
  1.  L +^GMPL(GMPFILE,LIST):5 I '$T D  Q
  1.  . W !,"Lock Error: error updating record #"_LIST_" in File #"_GMPFILE_"."
  1.  D UPDATE^DIE("","GMPFDA","","GMPERR")
  1.  L -^GMPL(GMPFILE,LIST)
  1.  Q
  1.  ;
  1. DELETE ; Delete problem group
  1.  N DIR,X,Y,DA,DIK,IFN,GMPLSEQ,GMPLDA S VALMBCK=$S(VALMCC:"",1:"R")
  1.  I $P($G(GMPLGRP),U,4)="N" W !!,"Cannot make edits to a National category." H 2 Q
  1.  I $D(^GMPL(125,"AC",+GMPLGRP)) W $C(7),!!,">>>  This category belongs to at least one problem selection list!",!,"     CANNOT DELETE" H 2 Q
  1.  S DIR(0)="YA",DIR("B")="NO",DIR("A")="Are you sure you want to delete the entire '"_$P(GMPLGRP,U,2)_"' category? "
  1.  S DIR("?")="Enter YES to completely remove this category and all its items."
  1.  D ^DIR Q:'Y
  1. DEL1 ; Ok, go for it ...
  1.  W !!,"Deleting category items ..."
  1.  S (GMPLSEQ,GMPLDA)=0
  1.  F  S GMPLSEQ=$O(^GMPL(125.11,"C",+GMPLGRP,GMPLSEQ)) Q:'GMPLSEQ  D
  1.  . F  S GMPLDA=$O(^GMPL(125.11,"C",+GMPLGRP,GMPLSEQ,GMPLDA)) Q:'GMPLDA  D
  1.  . . S DA(1)=+GMPLGRP,DA=GMPLDA,DIK="^GMPL(125.11,"_DA(1)_",1," D ^DIK W "."
  1.  . K ^GMPL(125.11,+GMPLGRP,1,0)
  1.  S DA=+GMPLGRP,DIK="^GMPL(125.11," D ^DIK W "."
  1.  L -^GMPL(125.11,+GMPLGRP,0) S GMPLGRP=0 K GMPLSAVE W " <done>"
  1.  D NEWGRP S:+GMPLGRP'>0 VALMBCK="Q"
  1.  Q
  1.  ;
  1. VALGRP(GMPLCAT,GMPLCODE) ; check all problems in the category for inactive SNOMED/ICD codes
  1.  ; Input:
  1.  ;    GMPLCAT  = ien from file 125.11
  1.  ;    GMPLCODE = Name of array where the categories & probs w/inactive codes are stored (Optional)
  1.  ;
  1.  ; Output:
  1.  ;    1     = category has no problems with inactive codes
  1.  ;    0     = category has one or more problems with inactive codes
  1.  ;    0^GMPLCODE = category has one or more problems with inactive codes^array w/inactive codes
  1.  ;    0^ERR = category is invalid^error message
  1.  ;
  1.  ; Array format (if returned):
  1.  ;    GMPLCODE(Category Name, Problem Sequence)=Display Text^(ICD-9/10-CM Code)^Inactive coding system (ICD,SCT,SCT/ICD)
  1.  ;
  1.  I '$G(GMPLCAT) Q "0^No category selected"
  1.  N GMPLSEQ,GMPLVALC,GMPLDA,GMPDT,GMPLCNME
  1.  S GMPLVALC=1,(GMPLSEQ,GMPLDA)=0,GMPDT=$$DT^XLFDT
  1.  S GMPLCNME=$$GET1^DIQ(125.11,GMPLCAT,.01)
  1.  F  S GMPLSEQ=$O(^GMPL(125.11,"C",GMPLCAT,GMPLSEQ)) Q:'GMPLSEQ  D
  1.  . F  S GMPLDA=$O(^GMPL(125.11,"C",GMPLCAT,GMPLSEQ,GMPLDA)) Q:'GMPLDA  D
  1.  . . N GMPLICD,GMPLSCTC,GMI,GMPLX,GMPSCT,GMPICD
  1.  . . N GMPLICDS,GMPLCLBL,GMPLCPTR,GMPCSYS,GMPLDTXT
  1.  . . S (GMPSCT,GMPICD)=0
  1.  . . S GMPLX=$G(^GMPL(125.11,GMPLCAT,1,GMPLDA,0))
  1.  . . S GMPLDTXT=$P(GMPLX,U,3)
  1.  . . S GMPLICD=$P(GMPLX,U,4),GMPLSCTC=$P(GMPLX,U,5)
  1.  . . Q:'$L(GMPLICD)&('$L(GMPLSCTC))  ; no code there
  1.  . . I $L(GMPLSCTC) D
  1.  . . . I '$$STATCHK^LEXSRC2(GMPLSCTC,GMPDT,"","SCT") S GMPLVALC=0,GMPSCT=1
  1.  . . S GMPLICDS=$$CODECS^ICDEX($P(GMPLICD,"/"),80,GMPDT)
  1.  . . S GMPLCPTR=$P(GMPLICDS,U),GMPLCLBL=$P(GMPLICDS,U,2)
  1.  . . I $L(GMPLICD) D
  1.  . . . F GMI=1:1:$L(GMPLICD,"/") D
  1.  . . . . I '$$STATCHK^ICDEX($P(GMPLICD,"/",GMI),GMPDT,GMPLCPTR) S GMPLVALC=0,GMPICD=1
  1.  . . I $D(GMPLCODE),(GMPSCT!GMPICD) D
  1.  . . . S GMPCSYS=$S((GMPSCT&GMPICD):"SCT/ICD",GMPSCT:"SCT",GMPICD:"ICD",1:"")
  1.  . . . S @GMPLCODE@(GMPLCNME,GMPLSEQ)=GMPLDTXT_U_"("_GMPLCLBL_" "_GMPLICD_")"_U_GMPCSYS
  1.  . Q
  1.  I $D(GMPLCODE),('GMPLVALC) S GMPLVALC=GMPLVALC_U_GMPLCODE
  1.  Q GMPLVALC
  1.  ;
  1. VALLIST(LIST,GMPLCODE) ;check all categories in list for probs w/ inactive SNOMED/ICD codes
  1.  ; Input:
  1.  ;   LIST = ien from file 125
  1.  ;   GMPLCODE = Name of array where the categories & probs w/inactive codes are stored (Optional)
  1.  ;
  1.  ; Output:
  1.  ;    1     = list has no problems with inactive codes
  1.  ;    0     = list has one or more problems with inactive codes
  1.  ;    0^GMPLCODE = list has one or more problems with inactive codes^array w/inactive codes
  1.  ;    O^ERR = list is invalid^error message
  1.  ;
  1.  ; Array format (if returned):
  1.  ;    GMPLCODE(Category Name, Problem Sequence)=Display Text^(ICD-9/10-CM Code)^Inactive coding system (ICD,SCT,SCT/ICD)
  1.  ;
  1.  N GMPLIEN,GMPLVAL
  1.  I '$G(LIST) Q 0
  1.  S GMPLCAT=0,GMPLVAL=1
  1.  F  S GMPLCAT=$O(^GMPL(125,LIST,1,"B",GMPLCAT)) Q:'GMPLCAT  D
  1.  . I $D(GMPLCODE) D
  1.  . . I '$$VALGRP(GMPLCAT,GMPLCODE) S GMPLVAL=0
  1.  . E  I '$$VALGRP(GMPLCAT) S GMPLVAL=0
  1.  . Q
  1.  I $D(GMPLCODE) S GMPLVAL=GMPLVAL_U_GMPLCODE
  1.  Q GMPLVAL
  1.  ;
  1. ASSIGN ; assign or remove selection list to users/clinic
  1.  ;
  1.  N GMPLENT,GMPLPAR,GMPJUST1,GMPLDTXT
  1.  I $D(VALMCC) D FULL^VALM1
  1.  S GMPLPAR=$$FIND1^DIC(8989.51,,"BX","ORQQPL SELECTION LIST")
  1.  I $D(GMPLPAR) S GMPLDTXT=$$GET1^DIQ(8989.51,GMPLPAR,.02),GMPLPAR=GMPLPAR_U_GMPLDTXT
  1.  F  D GETENT^XPAREDIT(.GMPLENT,GMPLPAR,.GMPJUST1) Q:'GMPLENT  D EDIT^XPAREDIT(GMPLENT,GMPLPAR) Q:GMPJUST1
  1.  I $D(VALMCC) S VALMBCK="R",VALMSG=$$MSG^GMPLX
  1.  Q