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

GMPLX.m

Go to the documentation of this file.
  1. GMPLX ; ISL/MKB,AJB,JER,TC,PKR -- Problem List Problem Utilities ;03/30/2020
  1. ;;2.0;Problem List;**7,23,26,28,27,36,42,40,49,53**;Aug 25, 1994;Build 159
  1. ;
  1. ; External References
  1. ; DBIA 446 ^AUTNPOV(
  1. ; ICR 5679 $$IMPDATE^LEXU
  1. ; ICR 5747 $$CSI/SAB^ICDEX
  1. ; ICR 6953 $$PROVNARR^PXAPI
  1. ; DBIA 10060 ^VA(200
  1. ; DBIA 10006 ^DIC
  1. ; DBIA 10009 FILE^DICN
  1. ; DBIA 10013 EN^DIK
  1. ; DBIA 10013 IX1^DIK
  1. ; DBIA 10026 ^DIR
  1. ; DBIA 1609 CONFIG^LEXSET
  1. ; DBIA 10103 $$FMTE^XLFDT
  1. ; DBIA 10104 $$UP^XLFSTR
  1. ; DBIA 2742 GMPLX
  1. ;
  1. N DIC S:'$L($G(VIEW)) VIEW="CLF" D CONFIG^LEXSET("GMPX",VIEW,DT)
  1. S DIC("A")=$S($L($G(PROMPT)):PROMPT,1:"Select PROBLEM: ")
  1. S DIC="^LEX(757.01,",DIC(0)=$S('$L($G(X)):"A",1:"")_"EQM"
  1. S:'$G(UNRES) LEXUN=0 D ^DIC
  1. I +Y>1 D
  1. .N CODE,SRC
  1. .S X=$P(Y,U,2)
  1. .D EXP2CODE(+Y,.SRC,.CODE)
  1. .I (SRC["SNOMED")!(SRC["VHAT") S (X,$P(Y,U,2))=X_" ("_$S(SRC["SNOMED":"SCT",1:"VHAT")_" "_CODE_")",Y(1)=$$GETDX(CODE,SRC)
  1. Q
  1. ;
  1. PROVNARR(X,CL) ; Returns IFN^Text of Narrative (#9999999.27)
  1. N RESULT
  1. S RESULT=$$PROVNARR^PXAPI(X,9000011,CL)
  1. I $P(RESULT,U,1)=-1 S RESULT=$$PROVNARR^PXAPI("Invalid narrative passed",9000011)
  1. Q $P(RESULT,U,1)
  1. ;
  1. PROBTEXT(IFN) ; Returns Display Text
  1. N X,Y,ICD,SCTC,GMPL0,GMPL800,GMPL802,GMPLEXP,GMPLPOV,GMPLSO,GMPLTXT,GMPLDT,GMPLCSYS,GMPLILBL
  1. S GMPL0=$G(^AUPNPROB(IFN,0)),GMPL800=$G(^(800)),GMPL802=$G(^(802))
  1. I '$L(GMPL0) S X="" G PROBTX
  1. S GMPLDT=$S(+$P(GMPL802,U,1):$P(GMPL802,U,1),1:$P(GMPL0,U,8))
  1. S GMPLCSYS=$S($P(GMPL802,U,2)]"":$P(GMPL802,U,2),1:$$SAB^ICDEX($$CSI^ICDEX(80,+GMPL0),GMPLDT))
  1. S GMPLILBL=$S(GMPLCSYS="10D":"ICD-10-CM ",1:"ICD-9-CM ")
  1. S ICD=$$CODEC^ICDEX(80,+GMPL0)
  1. S SCTC=$P(GMPL800,U,1)
  1. S Y=$P($G(^AUPNPROB(+IFN,0)),U,5),X=$P($G(^AUTNPOV(+Y,0)),U)
  1. S GMPLEXP=$$EP(IFN),GMPLSO=$$CS(X),GMPLPOV=$$PT(X,GMPLSO)
  1. S GMPLTXT=GMPLPOV S:$L(GMPLEXP) GMPLTXT=GMPLTXT_" ("_GMPLEXP_")"
  1. S:GMPLTXT["*" GMPLTXT=$TR(GMPLTXT,"*","")
  1. S:$L(GMPLTXT) GMPLTXT=GMPLTXT_$S($L($G(ICD))&('$L($G(SCTC))):" ("_GMPLILBL_$G(ICD)_")",$L($G(SCTC)):" (SCT "_$G(SCTC)_")",1:"")
  1. S:$L(GMPLTXT) X=GMPLTXT
  1. PROBTX Q X
  1. PROBNARR(IFN) ; Returns Provider Narrative
  1. N X,Y S Y=$P($G(^AUPNPROB(+IFN,0)),U,5),X=$P($G(^AUTNPOV(+Y,0)),U)
  1. Q X
  1. CS(X) ; Problem Codes
  1. N GMPLSAB,GMPLSO S GMPLSO="" S X=$G(X) Q:X'["(" ""
  1. F GMPLSAB="ICD-","CPT-","DSM-","HCPCS","NANDA","NIC","NOC","LOINC","SNOMED","OMAHA","SCT" S:$G(X)[("("_GMPLSAB) GMPLSO="("_GMPLSAB_$P(X,("("_GMPLSAB),2,299) Q:$L(GMPLSO)
  1. I $L(GMPLSO) S X=GMPLSO Q X
  1. F GMPLSAB="ACR","AI/RHEUM","CONGRESS","COSTAR","COSTART","CRISP","DODFAC" S:$G(X)[("("_GMPLSAB) GMPLSO="("_GMPLSAB_$P(X,("("_GMPLSAB),2,299) Q:$L(GMPLSO)
  1. I $L(GMPLSO) S X=GMPLSO Q X
  1. F GMPLSAB="DORLAND","DXPLAIN","HHCC","MCMASTER","META","MTF","MeSH","RVC","TITLE 38","UMDNS","UWA" S:$G(X)[("("_GMPLSAB) GMPLSO="("_GMPLSAB_$P(X,("("_GMPLSAB),2,299) Q:$L(GMPLSO)
  1. I $L(GMPLSO) S X=GMPLSO Q X
  1. Q ""
  1. EP(X) ; Exposures
  1. N GMPLSC S X=+($G(X)) D SCS^GMPLX1(+X,.GMPLSC) S X=$G(GMPLSC(1)) Q X
  1. PT(X,C) ; Problem Text (only)
  1. N GMPLTERM,GMPLSO S GMPLTERM=$G(X),GMPLSO=$G(C)
  1. S:$L(GMPLSO)&(GMPLTERM[GMPLSO) GMPLTERM=$P(GMPLTERM,GMPLSO,1) S GMPLTERM=$$TRIM(GMPLTERM)
  1. S:$L(GMPLTERM) X=GMPLTERM Q X
  1. TRIM(X) ; Trim Spaces and "*"
  1. S X=$G(X) F Q:$E(X,$L(X))'=" " S X=$E(X,1,($L(X)-1))
  1. F Q:$E(X,$L(X))'="*" S X=$E(X,1,($L(X)-1))
  1. F Q:$E(X,$L(X))'=" " S X=$E(X,1,($L(X)-1))
  1. F Q:$E(X,1)'=" " S X=$E(X,2,$L(X))
  1. Q X
  1. WRAP(PROB,MAX,TEXT) ; Splits Text into TEXT array
  1. N I,J S J=0 K TEXT I $L(PROB)'>MAX S J=J+1,TEXT(J)=PROB G WRQ
  1. WR0 ; Loop for Remaining Text
  1. S I=$F(PROB," ") I ('I)!(I>(MAX+2)) S J=J+1,TEXT(J)=$E(PROB,1,MAX),PROB=$E(PROB,MAX+1,999)
  1. I $L(PROB)>MAX F I=(MAX+1):-1:1 I $E(PROB,I)=" " S J=J+1,TEXT(J)=$E(PROB,1,I-1),PROB=$E(PROB,I+1,999) Q
  1. G:$L(PROB)>MAX WR0
  1. S:$L(PROB) J=J+1,TEXT(J)=PROB
  1. WRQ ; Quit Wrap
  1. S TEXT=J
  1. Q
  1. ;
  1. NOS(GMPLCSYS,GMPLDT) ; Return PTR^799.9 or PTR^R69 ICD code
  1. N CODE
  1. S:'$D(GMPLDT) GMPLDT=DT
  1. S:'$D(GMPLCSYS) GMPLCSYS=$S(GMPLDT<3151001:"ICD",1:"10D")
  1. S CODE=$S(GMPLCSYS="10D":"R69.",1:"799.9")
  1. Q +$$CODEN^ICDEX(CODE,80)_U_CODE
  1. ;
  1. SEL(HELP) ; Select List of Problems
  1. N X,Y,DIR,MAX,DTOUT S MAX=+$G(^TMP("GMPL",$J,0)) I MAX'>0 Q "^"
  1. S DIR(0)="LAO^1:"_MAX,DIR("A")="Select Problem(s)"
  1. S:MAX>1 DIR("A")=DIR("A")_" (1-"_MAX_"): "
  1. S:MAX'>1 DIR("A")=DIR("A")_": ",DIR("B")=1
  1. S DIR("?")="Enter the problems you wish to "
  1. S DIR("?")=DIR("?")_$S($L(HELP):HELP,1:"act on")_", as a range or list of numbers"
  1. D ^DIR I $D(DTOUT)!(X="") S Y="^"
  1. Q Y
  1. ;
  1. SEL1(HELP) ; Select 1 Problem
  1. N X,Y,DIR,MAX,DTOUT S MAX=+$G(^TMP("GMPL",$J,0)) I MAX'>0 Q "^"
  1. S DIR(0)="NAO^1:"_MAX_":0",DIR("A")="Select Problem"
  1. S:MAX>1 DIR("A")=DIR("A")_" (1-"_MAX_"): "
  1. S:MAX'>1 DIR("A")=DIR("A")_": ",DIR("B")=1
  1. S DIR("?")="Enter the number of the problem you wish to "
  1. S DIR("?")=DIR("?")_$S($L(HELP):HELP,1:"act on")
  1. D ^DIR I $D(DTOUT)!(X="") S Y="^"
  1. Q Y
  1. ;
  1. DUPL(DFN,TERM,TEXT) ; Check for Duplicates
  1. I '$D(^AUPNPROB("AC",DFN)) Q 0
  1. N CODE,CMAPL,ECODE,IND,MATCHIEN,MCODE,PROBIEN,RESULT
  1. N SCTCODE,SECCODE,SECMATCH,SOURCE,TEMP
  1. ;The rules for determining if there is a match are:
  1. ;
  1. ;1. For SCT problems mapped to multiple ICD diagnoses:
  1. ; If the SCT concept code, primary ICD diagnosis code, and secondary ICD
  1. ; diagnosis codes match that of a pre-existing problem, it's a
  1. ; duplicate.
  1. ;
  1. ;2. For SCT problems mapped to an unspecified ICD diagnosis (799.9 or
  1. ;R69) code:
  1. ; If the SCT concept code matches that of a pre-existing problem, it's
  1. ; a duplicate.
  1. ;
  1. ;3. For all other SCT problems, those mapped to a single primary ICD
  1. ;diagnosis:
  1. ; If the SCT concept code and primary ICD diagnosis code matches that
  1. ; of a pre-existing problem, it's a duplicate.
  1. ;
  1. S (MATCHIEN,PROBIEN)=0
  1. F Q:MATCHIEN>0 S PROBIEN=+$O(^AUPNPROB("AC",DFN,PROBIEN)) Q:PROBIEN=0 D
  1. . S SCTCODE=$P($G(^AUPNPROB(PROBIEN,800)),U,1)
  1. . I SCTCODE="" Q
  1. .;Skip Hidden Problems
  1. .;If there is no SCT code it is a legacy problem.
  1. . I $P(^AUPNPROB(PROBIEN,1),U,2)="H" Q
  1. .;
  1. .;SCT-ICD entry
  1. . D EXP2CODE(TERM,.SOURCE,.ECODE)
  1. . I SOURCE'="SNOMED CT" Q
  1. . I ECODE'=SCTCODE Q
  1. . K CMAPL
  1. . S RESULT=$$GETASSN^LEXTRAN1(SCTCODE,"SCT210D",DT,"CMAPL")
  1. .;No mapped code, so the match is because ECODE=SCTCODE
  1. . I +RESULT=0 S MATCHIEN=PROBIEN Q
  1. .;The primary code must match.
  1. . S MCODE=$O(CMAPL(1,""))
  1. . I MCODE="R69." S MATCHIEN=PROBIEN Q
  1. . S TEMP=^AUPNPROB(PROBIEN,0)
  1. . S CODE=$$CODEC^ICDEX(80,$P(TEMP,U,1))
  1. . I CODE'=MCODE Q
  1. .;All secondary codes must match.
  1. . S SECMATCH=1
  1. . F IND=2:1:CMAPL D
  1. .. S SECCODE=$O(CMAPL(2,""))
  1. .. I '$D(^AUPNPROB(PROBIEN,803,"B",SECCODE)) S SECMATCH=0
  1. . I SECMATCH S MATCHIEN=PROBIEN
  1. Q MATCHIEN
  1. ;
  1. DUPLOK(IFN) ; Ask if Dup OK
  1. N DIR,X,Y,GMPL0,GMPL1,DATE,PROV S DIR(0)="YA",GMPL0=$G(^AUPNPROB(IFN,0)),GMPL1=$G(^(1))
  1. S DIR("A")="Are you sure you want to continue? ",DIR("B")="NO"
  1. S DIR("?",1)="Enter YES if you want to duplicate this problem on this patient's list;",DIR("?")="press <return> to re-enter the problem name."
  1. W $C(7),!!,">>> "_$$PROBTEXT(IFN),!?5,"is already an "
  1. W $S($P(GMPL0,U,12)="I":"IN",1:"")_"ACTIVE problem on this patient's list!",!
  1. S PROV=+$P(GMPL1,U,5) W:PROV !?5,"Provider: "_$P($G(^VA(200,PROV,0)),U)_" ("_$P($$SERVICE^GMPLX1(PROV),U,2)_")"
  1. I $P(GMPL0,U,12)="A" W !?8,"Onset: " S DATE=$P(GMPL0,U,13)
  1. I $P(GMPL0,U,12)="I" W !?5,"Resolved: " S DATE=$P(GMPL1,U,7)
  1. W $S(DATE>0:$$FMTE^XLFDT(DATE),1:"unspecified"),!
  1. D ^DIR W !
  1. Q +Y
  1. ;
  1. LOCKED() ; Return Lock Msg
  1. Q "This problem is currently being edited by another user!"
  1. ;
  1. SURE() ; Ask to Delete
  1. ; Returns 1 if YES, else 0
  1. N DIR,X,Y S DIR(0)="YA",DIR("B")="NO"
  1. S DIR("?")="Enter YES to remove this value or NO to leave it unchanged."
  1. S DIR("A")="Are you sure you want to remove this value? " D ^DIR
  1. Q +Y
  1. ;
  1. EXTDT(DATE) ; Format Date as MM/DD/YY
  1. N X,MM,DD,YY,YYY S X="",DATE=$P(DATE,".") Q:'DATE ""
  1. S MM=+$E(DATE,4,5),DD=+$E(DATE,6,7),YY=$E(DATE,2,3),YYY=$E(DATE,1,3)
  1. S:MM X=MM_"/" S:DD X=X_DD_"/" S X=$S($L(X):X_YY,1:1700+YYY)
  1. Q X
  1. ;
  1. AUDIT(DATA,OLD) ; Make Entry in Audit File
  1. ; DATA = string for 0-node
  1. ; OLD = string for 1-node
  1. ; = 0-node from reform/react problem
  1. N DA,DD,DO,DIC,X,Y,DIK,DLAYGO
  1. S DIC="^GMPL(125.8,",DIC(0)="L",X=$P(DATA,U),DLAYGO=125.8
  1. D FILE^DICN Q:+Y'>0 S DA=+Y,DIK="^GMPL(125.8,"
  1. S ^GMPL(125.8,DA,0)=DATA D IX1^DIK
  1. S:$L(OLD) ^GMPL(125.8,DA,1)=OLD
  1. Q
  1. ;
  1. DTMOD(DA) ; Update Date Modified
  1. N DIE,DR
  1. S DR=".03///TODAY",DIE="^AUPNPROB("
  1. D ^DIE
  1. ; broadcast problem change events
  1. N GMPIFN,DFN,X
  1. S GMPIFN=DA,DFN=+$P($G(^AUPNPROB(DA,0)),U,2)
  1. S X=+$O(^ORD(101,"B","GMPL EVENT",0))_";ORD(101," D:X EN1^XQOR
  1. Q
  1. ;
  1. MSG() ; List Manager Msg Bar
  1. Q "+ Next Screen - Prev Screen ?? More actions"
  1. ;
  1. KILL ; Clean-Up variables
  1. K X,Y,DIC,DIE,DR,DA,DUOUT,DTOUT,GMPQUIT,GMPRT,GMPSAVED,GMPIFN,GMPLNO,GMPLNUM,GMPLSEL,GMPREBLD,GMPI,GMPLSLST,GMPLJUMP
  1. Q
  1. ;
  1. CODESTS(PROB,ADATE) ;check status of ICD
  1. ; Input:
  1. ; PROB = pointer to the PROBLEM (#9000011) file
  1. ; ADATE = FM date on which to check the status (opt.)
  1. ;
  1. ; Output:
  1. ; 1 = ACTIVE on the date passed or current date
  1. ; 0 = INACTIVE on the date passed or current date
  1. ;
  1. I '$G(ADATE) S ADATE=DT
  1. I '$D(^AUPNPROB(PROB,0)) Q 0
  1. N GMPLCPTR,GMPLSTAT
  1. S GMPLCPTR=$P(^AUPNPROB(PROB,0),U,1)
  1. S GMPLSTAT=+$$SAI^ICDEX(80,GMPLCPTR,ADATE)
  1. Q GMPLSTAT
  1. ;
  1. EXP2CODE(X,GMPSRC,GMPCODE) ; Resolve SOURCE,CODE and EXPRESSION
  1. ;from the Expressions file.
  1. N IND,GMI,LEX,SRCCODE
  1. S GMI=0,(GMPSRC,GMPCODE)=""
  1. D INFO^LEXA(X,DT)
  1. F S GMI=$O(LEX("SEL","SRC",GMI)) Q:+GMI'>0 D Q:($G(GMPSRC)]"")
  1. . S SRCCODE=$P($G(LEX("SEL","SRC",GMI)),U,1,2)
  1. . I $P(SRCCODE,U)["SNOMED CT"!($P(SRCCODE,U)["VHAT")!($P(SRCCODE,U)["ICD") S GMPSRC=$P(SRCCODE,U),GMPCODE=$P(SRCCODE,U,2)
  1. Q
  1. ;
  1. GETDX(CODE,CODESYS,GMPDT) ; Get ICD associated with SCT or VHAT Code
  1. N LEX,GMPI,GMPY,GMPMPDEF,GMPIMPDT S GMPDT=$G(GMPDT,$$DT^XLFDT)
  1. S GMPY=0,GMPIMPDT=$$IMPDATE^LEXU("10D")
  1. S GMPMPDEF=$S(GMPDT<GMPIMPDT:"SCT2ICD",1:"SCT210D")
  1. I CODESYS["VHAT" S GMPY=$$GETASSN^LEXTRAN1(CODE,"VHAT2ICD",GMPDT) I 1
  1. E S GMPY=$$GETASSN^LEXTRAN1(CODE,GMPMPDEF,GMPDT)
  1. I $S(+GMPY'>0:1,+$P(GMPY,U,2)'>0:1,+LEX'>0:1,1:0) S GMPY=$S(GMPDT<GMPIMPDT:"799.9",1:"R69.") G GETDXX
  1. S (GMPI,GMPY)=0
  1. F S GMPI=$O(LEX(GMPI)) Q:+GMPI'>0 D
  1. .N ICD
  1. .S ICD=$O(LEX(GMPI,""))
  1. .I ICD]"" S GMPY=$S(GMPY'=0:GMPY_"/",1:"")_ICD
  1. I GMPY'["." S GMPY=GMPY_"."
  1. GETDXX Q GMPY
  1. ;
  1. PAD(GMPX,GMPL) ; Pads string to specified length
  1. N GMPY
  1. S GMPY="",$P(GMPY," ",(GMPL-$L(GMPX))+1)=""
  1. Q GMPY
  1. ;
  1. GETEXIEN(GMPLSCTC,GMPLSCTD) ; Get Lexicon Expression IEN for SNOMED term
  1. N GMPLSYN,GMPLDT,GMPLRSLT,GMPLIEN,GMPLTYP,GMPLQT,GMPLNUM
  1. I '$D(GMPLSCTC)!('$D(GMPLSCTD)) S GMPLIEN="-1^Missing "_$S('$D(GMPLSCTC):"SNOMED CT Concept ID",1:"SNOMED CT Designation ID") G GETEXQT
  1. S GMPLDT=$$DT^XLFDT,(GMPLTYP,GMPLNUM,GMPLQT)=""
  1. S GMPLRSLT=$$GETSYN^LEXTRAN1("SCT",GMPLSCTC,GMPLDT,"GMPLSYN",1,1)
  1. I +GMPLRSLT<0 S GMPLIEN=GMPLRSLT G GETEXQT
  1. F S GMPLTYP=$O(GMPLSYN(GMPLTYP)) Q:GMPLTYP=""!(GMPLQT) D
  1. . I GMPLTYP="S" D
  1. . . F S GMPLNUM=$O(GMPLSYN(GMPLTYP,GMPLNUM)) Q:GMPLNUM=""!(GMPLQT) D
  1. . . . I $P(GMPLSYN(GMPLTYP,GMPLNUM),U,3)=GMPLSCTD S GMPLIEN=$P(GMPLSYN(GMPLTYP,GMPLNUM),U,2),GMPLQT=1 Q
  1. . . Q:GMPLQT
  1. . E I $P(GMPLSYN(GMPLTYP),U,3)=GMPLSCTD S GMPLIEN=$P(GMPLSYN(GMPLTYP),U,2),GMPLQT=1 Q
  1. I GMPLQT="" S GMPLIEN="-1^Cannot find Expression IEN"
  1. GETEXQT Q GMPLIEN
  1. ;
  1. STRIPSPC(GMPLTXT) ; Strip string of spaces and convert to all uppercase for comparison
  1. N GMPLSTR,GMPLCHAR S GMPLCHAR=" "
  1. S GMPLSTR=$$UP^XLFSTR($$STRIP^XLFSTR(GMPLTXT,GMPLCHAR))
  1. Q GMPLSTR
  1. ;
  1. MIXLOWCS(GMPLTXT) ; Check for mix/lower case
  1. N GMPLRSLT,GMPLPUNC S GMPLRSLT=0
  1. S GMPLPUNC=" ,!,"",#,$,%,&,',(,),*,+,-,,,_,.,/,\,:,;,<,=,>,?,@,[,],^,`,~,|,{,}"
  1. S GMPLTXT=$$STRIP^XLFSTR($TR(GMPLTXT,GMPLPUNC," ")," ")
  1. I GMPLTXT?.L1.(1.U1.L)!(GMPLTXT?1.L) S GMPLRSLT=1
  1. Q GMPLRSLT
  1. ;
  1. PAUSE ; Pause for user to process info
  1. I $E(IOST,1,2)="C-" D
  1. . N DIR,DTOUT,DIRUT,DUOUT,X,Y
  1. . S DIR(0)="E" D ^DIR
  1. Q
  1. ;