GMPLX ; ISL/MKB,AJB,JER,TC -- Problem List Problem Utilities ;07/03/17 09:13
;;2.0;Problem List;**7,23,26,28,27,36,42,40,49**;Aug 25, 1994;Build 43
;
; External References
; DBIA 446 ^AUTNPOV(
; ICR 5679 $$IMPDATE^LEXU
; ICR 5699 $$ICDDATA^ICDXCODE,$$STATCHK^ICDXCODE
; ICR 5747 $$CSI/SAB^ICDEX
; DBIA 10060 ^VA(200
; DBIA 10006 ^DIC
; DBIA 10009 FILE^DICN
; DBIA 10013 EN^DIK
; DBIA 10013 IX1^DIK
; DBIA 10026 ^DIR
; DBIA 1609 CONFIG^LEXSET
; DBIA 10103 $$FMTE^XLFDT
; DBIA 10104 $$UP^XLFSTR
; DBIA 2742 GMPLX
;
SEARCH(X,Y,PROMPT,UNRES,VIEW) ; Search Lexicon for Problem X
N DIC S:'$L($G(VIEW)) VIEW="CLF" D CONFIG^LEXSET("GMPX",VIEW,DT)
S DIC("A")=$S($L($G(PROMPT)):PROMPT,1:"Select PROBLEM: ")
S DIC="^LEX(757.01,",DIC(0)=$S('$L($G(X)):"A",1:"")_"EQM"
S:'$G(UNRES) LEXUN=0 D ^DIC
I +Y>1 D
.N CODE,SRC
.S X=$P(Y,U,2)
.D EXP2CODE(+Y,.SRC,.CODE)
.I (SRC["SNOMED")!(SRC["VHAT") S (X,$P(Y,U,2))=X_" ("_$S(SRC["SNOMED":"SCT",1:"VHAT")_" "_CODE_")",Y(1)=$$GETDX(CODE,SRC)
Q
;
PROVNARR(X,CL) ; Returns IFN ^ Text of Narrative (#9999999.27)
N DIC,Y,DLAYGO,DD,DO,DA S:$L(X)>245 X=$E(X,1,245)
S DIC="^AUTNPOV(",DIC(0)="L",DLAYGO=9999999.27,(DA,Y)=0
F S DA=$O(^AUTNPOV("B",$E(X,1,30),DA)) Q:DA'>0 I $P(^AUTNPOV(DA,0),U)=X S Y=DA_U_X Q
I '(+Y) K DA,Y D FILE^DICN S:Y'>0 Y=U_X I Y>0,CL>1 S ^AUTNPOV(+Y,757)=CL
Q $P(Y,U,1,2)
;
PROBTEXT(IFN) ; Returns Display Text
N X,Y,ICD,SCTC,GMPL0,GMPL800,GMPL802,GMPLEXP,GMPLPOV,GMPLSO,GMPLTXT,GMPLDT,GMPLCSYS,GMPLILBL
S GMPL0=$G(^AUPNPROB(IFN,0)),GMPL800=$G(^(800)),GMPL802=$G(^(802))
I '$L(GMPL0) S X="" G PROBTX
S GMPLDT=$S(+$P(GMPL802,U,1):$P(GMPL802,U,1),1:$P(GMPL0,U,8)),GMPLCSYS=$S($P(GMPL802,U,2)]"":$P(GMPL802,U,2),1:$$SAB^ICDEX($$CSI^ICDEX(80,+GMPL0),GMPLDT))
S GMPLILBL=$S(GMPLCSYS="10D":"ICD-10-CM ",1:"ICD-9-CM ")
S ICD=$P($$ICDDATA^ICDXCODE(GMPLCSYS,+GMPL0,GMPLDT,"I"),U,2),SCTC=$P(GMPL800,U)
S Y=$P($G(^AUPNPROB(+IFN,0)),U,5),X=$P($G(^AUTNPOV(+Y,0)),U)
S GMPLEXP=$$EP(IFN),GMPLSO=$$CS(X),GMPLPOV=$$PT(X,GMPLSO)
S GMPLTXT=GMPLPOV S:$L(GMPLEXP) GMPLTXT=GMPLTXT_" ("_GMPLEXP_")"
;S:$L(GMPLSO)&(GMPLSO'["SNOMED") GMPLTXT=GMPLTXT_" "_GMPLSO
S:GMPLTXT["*" GMPLTXT=$TR(GMPLTXT,"*","")
;S:$L(GMPLTXT) GMPLTXT=GMPLTXT_" ("_$$HFP^GMPLUTL4_","_$$PTR^GMPLUTL4_")"
S:$L(GMPLTXT) GMPLTXT=GMPLTXT_$S($L($G(ICD))&('$L($G(SCTC))):" ("_GMPLILBL_$G(ICD)_")",$L($G(SCTC)):" (SCT "_$G(SCTC)_")",1:"")
S:$L(GMPLTXT) X=GMPLTXT
PROBTX Q X
PROBNARR(IFN) ; Returns Provider Narrative
N X,Y S Y=$P($G(^AUPNPROB(+IFN,0)),U,5),X=$P($G(^AUTNPOV(+Y,0)),U)
Q X
CS(X) ; Problem Codes
N GMPLSAB,GMPLSO S GMPLSO="" S X=$G(X) Q:X'["(" ""
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)
I $L(GMPLSO) S X=GMPLSO Q X
F GMPLSAB="ACR","AI/RHEUM","CONGRESS","COSTAR","COSTART","CRISP","DODFAC" S:$G(X)[("("_GMPLSAB) GMPLSO="("_GMPLSAB_$P(X,("("_GMPLSAB),2,299) Q:$L(GMPLSO)
I $L(GMPLSO) S X=GMPLSO Q X
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)
I $L(GMPLSO) S X=GMPLSO Q X
Q ""
EP(X) ; Exposures
N GMPLSC S X=+($G(X)) D SCS^GMPLX1(+X,.GMPLSC) S X=$G(GMPLSC(1)) Q X
PT(X,C) ; Problem Text (only)
N GMPLTERM,GMPLSO S GMPLTERM=$G(X),GMPLSO=$G(C)
S:$L(GMPLSO)&(GMPLTERM[GMPLSO) GMPLTERM=$P(GMPLTERM,GMPLSO,1) S GMPLTERM=$$TRIM(GMPLTERM)
S:$L(GMPLTERM) X=GMPLTERM Q X
TRIM(X) ; Trim Spaces and "*"
S X=$G(X) F Q:$E(X,$L(X))'=" " S X=$E(X,1,($L(X)-1))
F Q:$E(X,$L(X))'="*" S X=$E(X,1,($L(X)-1))
F Q:$E(X,$L(X))'=" " S X=$E(X,1,($L(X)-1))
F Q:$E(X,1)'=" " S X=$E(X,2,$L(X))
Q X
WRAP(PROB,MAX,TEXT) ; Splits Text into TEXT array
N I,J S J=0 K TEXT I $L(PROB)'>MAX S J=J+1,TEXT(J)=PROB G WRQ
WR0 ; Loop for Remaining Text
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)
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
G:$L(PROB)>MAX WR0
S:$L(PROB) J=J+1,TEXT(J)=PROB
WRQ ; Quit Wrap
S TEXT=J
Q
;
NOS(GMPLCSYS,GMPLDT) ; Return PTR ^ 799.9 or PTR ^ R69 ICD code
N GMPIMPDT S GMPIMPDT=$$IMPDATE^LEXU("10D")
S:'$D(GMPLDT) GMPLDT=DT
S:'$D(GMPLCSYS) GMPLCSYS=$S(GMPLDT<GMPIMPDT:"ICD",1:"10D")
Q $S(GMPLCSYS="10D":+$$ICDDATA^ICDXCODE(GMPLCSYS,"R69.",GMPLDT,"E")_"^R69.",1:+$$ICDDATA^ICDXCODE(GMPLCSYS,"799.9",GMPLDT,"E")_"^799.9")
;
SEL(HELP) ; Select List of Problems
N X,Y,DIR,MAX,DTOUT S MAX=+$G(^TMP("GMPL",$J,0)) I MAX'>0 Q "^"
S DIR(0)="LAO^1:"_MAX,DIR("A")="Select Problem(s)"
S:MAX>1 DIR("A")=DIR("A")_" (1-"_MAX_"): "
S:MAX'>1 DIR("A")=DIR("A")_": ",DIR("B")=1
S DIR("?")="Enter the problems you wish to "
S DIR("?")=DIR("?")_$S($L(HELP):HELP,1:"act on")_", as a range or list of numbers"
D ^DIR I $D(DTOUT)!(X="") S Y="^"
Q Y
;
SEL1(HELP) ; Select 1 Problem
N X,Y,DIR,MAX,DTOUT S MAX=+$G(^TMP("GMPL",$J,0)) I MAX'>0 Q "^"
S DIR(0)="NAO^1:"_MAX_":0",DIR("A")="Select Problem"
S:MAX>1 DIR("A")=DIR("A")_" (1-"_MAX_"): "
S:MAX'>1 DIR("A")=DIR("A")_": ",DIR("B")=1
S DIR("?")="Enter the number of the problem you wish to "
S DIR("?")=DIR("?")_$S($L(HELP):HELP,1:"act on")
D ^DIR I $D(DTOUT)!(X="") S Y="^"
Q Y
;
DUPL(DFN,TERM,TEXT) ; Check for Duplicates
N DA,IFN,GMPOTHR,GMPNOW S DA=0,TEXT=$$UP^XLFSTR($S(TEXT["SCT":$P(TEXT," (SCT"),1:TEXT))
I '$D(^AUPNPROB("AC",DFN)) G DUPLX
S GMPNOW=$E($$NOW^XLFDT,1,7)
S GMPOTHR=$S(GMPNOW<($$IMPDATE^LEXU("10D")):"799.9",1:"R69.")
F IFN=0:0 S IFN=$O(^AUPNPROB("AC",DFN,IFN)) Q:IFN'>0 D Q:DA>0
.N PICDOLD,PICDNEW,NODE0,NODE1,NODE800,NODE802,NODE803,SCTD,PROVNAR,EXPTXT,GMPSRC,GMPCODE,GMPLDT,GMPLCSYS
.S NODE0=$G(^AUPNPROB(IFN,0)),NODE1=$G(^(1)),NODE800=$G(^(800)),NODE802=$G(^(802)),NODE803=$G(^(803,0)) Q:$P(NODE1,U,2)="H"
.S GMPLDT=$S(+$P(NODE802,U,1):$P(NODE802,U,1),1:$P(NODE0,U,8)),GMPLCSYS=$S($P(NODE802,U,2)]"":$P(NODE802,U,2),1:$$SAB^ICDEX($$CSI^ICDEX(80,+NODE0),GMPLDT))
.S PICDOLD=$P($$ICDDATA^ICDXCODE(GMPLCSYS,+NODE0,GMPLDT,"I"),U,2)
.D EXP2CODE(TERM,.GMPSRC,.GMPCODE)
.S ICDNEW=$S(GMPSRC="SNOMED CT":$$GETDX(GMPCODE,GMPSRC),1:GMPCODE)
.S PICDNEW=$P(ICDNEW,"/")
.;Compare problems with SNOMED CT concept codes & ICD code(s) only
.I +NODE800,(GMPSRC="SNOMED CT"),(+$G(GMPCODE)>0),($L(ICDNEW)) D Q
..;if SCT concepts & primary + multiple ICD targets match => dup
..I $P(NODE803,U,4)>0,ICDNEW["/" D
...N I,J,SICDNEW S J=0 F I=2:1:$L(ICDNEW,"/") D
....S J=J+1,SICDNEW(J)=$P(ICDNEW,"/",I)
...N T F T=1:1:J D
....N IEN S IEN=0 F S IEN=$O(^AUPNPROB(IFN,803,IEN)) Q:'+IEN D
.....I +NODE800=GMPCODE,(PICDOLD=PICDNEW),$P($G(^AUPNPROB(IFN,803,IEN,0)),U)=SICDNEW(T) S DA=IFN Q
..;if SCT concept codes match => dup
..E I ICDNEW=GMPOTHR!(PICDNEW=GMPOTHR) D
...I +NODE800=GMPCODE S DA=IFN Q
..;if SCT concepts & primary ICD diagnosis match => dup
..E I +NODE800=GMPCODE,(PICDOLD=PICDNEW) S DA=IFN Q
.;Compare legacy problems with ICD codes only
.E I +NODE0,'$L($G(NODE800)),(GMPSRC["ICD"),(+$G(GMPCODE)>0) D
..;if Exprs match => dup
..I TERM>1&(+NODE1=TERM) S DA=IFN Q
..;if Text matches Expr from old => dup
..D LOOK^LEXA("`"_+NODE1)
..S EXPTXT=$P($G(LEX("LIST",1)),U,2)
..I LEX>1&(TEXT=$$UP^XLFSTR($S(EXPTXT["*":$P(EXPTXT," *"),1:EXPTXT))) S DA=IFN Q
..;if Text matches Prov Narr of old => dup
..S PROVNAR=$S($P(NODE0,U,5)]"":$P(^AUTNPOV($P(NODE0,U,5),0),U),1:"")
..I TEXT=$$UP^XLFSTR($S(PROVNAR["SNOMED":$P(PROVNAR," (SN"),PROVNAR[" *":$P(PROVNAR,"*"),1:PROVNAR)) S DA=IFN Q
..;if prim ICD of new = prim ICD of old => dup
..I PICDOLD'=GMPOTHR,(PICDNEW'=GMPOTHR),(PICDOLD=PICDNEW) S DA=IFN Q
DUPLX Q DA
;
DUPLOK(IFN) ; Ask if Dup OK
N DIR,X,Y,GMPL0,GMPL1,DATE,PROV S DIR(0)="YA",GMPL0=$G(^AUPNPROB(IFN,0)),GMPL1=$G(^(1))
S DIR("A")="Are you sure you want to continue? ",DIR("B")="NO"
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."
W $C(7),!!,">>> "_$$PROBTEXT(IFN),!?5,"is already an "
W $S($P(GMPL0,U,12)="I":"IN",1:"")_"ACTIVE problem on this patient's list!",!
S PROV=+$P(GMPL1,U,5) W:PROV !?5,"Provider: "_$P($G(^VA(200,PROV,0)),U)_" ("_$P($$SERVICE^GMPLX1(PROV),U,2)_")"
I $P(GMPL0,U,12)="A" W !?8,"Onset: " S DATE=$P(GMPL0,U,13)
I $P(GMPL0,U,12)="I" W !?5,"Resolved: " S DATE=$P(GMPL1,U,7)
W $S(DATE>0:$$FMTE^XLFDT(DATE),1:"unspecified"),!
D ^DIR W !
Q +Y
;
LOCKED() ; Return Lock Msg
Q "This problem is currently being edited by another user!"
;
SURE() ; Ask to Delete
; Returns 1 if YES, else 0
N DIR,X,Y S DIR(0)="YA",DIR("B")="NO"
S DIR("?")="Enter YES to remove this value or NO to leave it unchanged."
S DIR("A")="Are you sure you want to remove this value? " D ^DIR
Q +Y
;
EXTDT(DATE) ; Format Date as MM/DD/YY
N X,MM,DD,YY,YYY S X="",DATE=$P(DATE,".") Q:'DATE ""
S MM=+$E(DATE,4,5),DD=+$E(DATE,6,7),YY=$E(DATE,2,3),YYY=$E(DATE,1,3)
S:MM X=MM_"/" S:DD X=X_DD_"/" S X=$S($L(X):X_YY,1:1700+YYY)
Q X
;
AUDIT(DATA,OLD) ; Make Entry in Audit File
; DATA = string for 0-node
; OLD = string for 1-node
; = 0-node from reform/react problem
N DA,DD,DO,DIC,X,Y,DIK,DLAYGO
S DIC="^GMPL(125.8,",DIC(0)="L",X=$P(DATA,U),DLAYGO=125.8
D FILE^DICN Q:+Y'>0 S DA=+Y,DIK="^GMPL(125.8,"
S ^GMPL(125.8,DA,0)=DATA D IX1^DIK
S:$L(OLD) ^GMPL(125.8,DA,1)=OLD
Q
;
DTMOD(DA) ; Update Date Modified
N DIE,DR
S DR=".03///TODAY",DIE="^AUPNPROB("
D ^DIE
; broadcast problem change events
N GMPIFN,DFN,X
S GMPIFN=DA,DFN=+$P($G(^AUPNPROB(DA,0)),U,2)
S X=+$O(^ORD(101,"B","GMPL EVENT",0))_";ORD(101," D:X EN1^XQOR
Q
;
MSG() ; ListMan Msg Bar
Q "+ Next Screen - Prev Screen ?? More actions"
;
KILL ; Clean-Up Vars
K X,Y,DIC,DIE,DR,DA,DUOUT,DTOUT,GMPQUIT,GMPRT,GMPSAVED,GMPIFN,GMPLNO,GMPLNUM,GMPLSEL,GMPREBLD,GMPI,GMPLSLST,GMPLJUMP
Q
;
CODESTS(PROB,ADATE) ;check status of ICD
; Input:
; PROB = pointer to the PROBLEM (#9000011) file
; ADATE = FM date on which to check the status (opt.)
;
; Output:
; 1 = ACTIVE on the date passed or current date
; 0 = INACTIVE on the date passed or current date
;
I '$G(ADATE) S ADATE=DT
I '$D(^AUPNPROB(PROB,0)) Q 0
N GMPL0,GMPL802,GMPLCSYS,GMPLCPTR,GMPLICD S GMPL0=$G(^AUPNPROB(PROB,0)),GMPL802=$G(^(802))
S GMPLCPTR=$$CSI^ICDEX(80,+GMPL0),GMPLCSYS=$S($P(GMPL802,U,2)]"":$P(GMPL802,U,2),1:$$SAB^ICDEX(GMPLCPTR,ADATE))
S GMPLICD=$P($$ICDDATA^ICDXCODE(GMPLCSYS,+GMPL0,ADATE,"I"),U,2)
Q +$$STATCHK^ICDXCODE(GMPLCPTR,GMPLICD,ADATE)
EXP2CODE(X,GMPSRC,GMPCODE) ; Resolve SOURCE and CODE from Expression
N LEX,SRCCODE,GMI S GMI=0,(GMPSRC,GMPCODE)=""
D INFO^LEXA(X,DT)
F S GMI=$O(LEX("SEL","SRC",GMI)) Q:+GMI'>0 D Q:($G(GMPSRC)]"")
. S SRCCODE=$P($G(LEX("SEL","SRC",GMI)),U,1,2)
. I $P(SRCCODE,U)["SNOMED CT"!($P(SRCCODE,U)["VHAT")!($P(SRCCODE,U)["ICD") S GMPSRC=$P(SRCCODE,U),GMPCODE=$P(SRCCODE,U,2)
Q
GETDX(CODE,CODESYS,GMPDT) ; Get ICD associated with SCT or VHAT Code
N LEX,GMPI,GMPY,GMPMPDEF,GMPIMPDT S GMPDT=$G(GMPDT,$$DT^XLFDT)
S GMPY=0,GMPIMPDT=$$IMPDATE^LEXU("10D")
S GMPMPDEF=$S(GMPDT<GMPIMPDT:"SCT2ICD",1:"SCT210D")
I CODESYS["VHAT" S GMPY=$$GETASSN^LEXTRAN1(CODE,"VHAT2ICD",GMPDT) I 1
E S GMPY=$$GETASSN^LEXTRAN1(CODE,GMPMPDEF,GMPDT)
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
S (GMPI,GMPY)=0
F S GMPI=$O(LEX(GMPI)) Q:+GMPI'>0 D
.N ICD
.S ICD=$O(LEX(GMPI,""))
.I ICD]"" S GMPY=$S(GMPY'=0:GMPY_"/",1:"")_ICD
I GMPY'["." S GMPY=GMPY_"."
GETDXX Q GMPY
PAD(GMPX,GMPL) ; Pads string to specified length
N GMPY
S GMPY="",$P(GMPY," ",(GMPL-$L(GMPX))+1)=""
Q GMPY
GETEXIEN(GMPLSCTC,GMPLSCTD) ; Get Lexicon Expression IEN for SNOMED term
N GMPLSYN,GMPLDT,GMPLRSLT,GMPLIEN,GMPLTYP,GMPLQT,GMPLNUM
I '$D(GMPLSCTC)!('$D(GMPLSCTD)) S GMPLIEN="-1^Missing "_$S('$D(GMPLSCTC):"SNOMED CT Concept ID",1:"SNOMED CT Designation ID") G GETEXQT
S GMPLDT=$$DT^XLFDT,(GMPLTYP,GMPLNUM,GMPLQT)=""
S GMPLRSLT=$$GETSYN^LEXTRAN1("SCT",GMPLSCTC,GMPLDT,"GMPLSYN",1,1)
I +GMPLRSLT<0 S GMPLIEN=GMPLRSLT G GETEXQT
F S GMPLTYP=$O(GMPLSYN(GMPLTYP)) Q:GMPLTYP=""!(GMPLQT) D
. I GMPLTYP="S" D
. . F S GMPLNUM=$O(GMPLSYN(GMPLTYP,GMPLNUM)) Q:GMPLNUM=""!(GMPLQT) D
. . . I $P(GMPLSYN(GMPLTYP,GMPLNUM),U,3)=GMPLSCTD S GMPLIEN=$P(GMPLSYN(GMPLTYP,GMPLNUM),U,2),GMPLQT=1 Q
. . Q:GMPLQT
. E I $P(GMPLSYN(GMPLTYP),U,3)=GMPLSCTD S GMPLIEN=$P(GMPLSYN(GMPLTYP),U,2),GMPLQT=1 Q
I GMPLQT="" S GMPLIEN="-1^Cannot find Expression IEN"
GETEXQT Q GMPLIEN
STRIPSPC(GMPLTXT) ; Strip string of spaces and convert to all uppercase for comparison
N GMPLSTR,GMPLCHAR S GMPLCHAR=" "
S GMPLSTR=$$UP^XLFSTR($$STRIP^XLFSTR(GMPLTXT,GMPLCHAR))
Q GMPLSTR
;
MIXLOWCS(GMPLTXT) ; Check for mix/lower case
N GMPLRSLT,GMPLPUNC S GMPLRSLT=0
S GMPLPUNC=" ,!,"",#,$,%,&,',(,),*,+,-,,,_,.,/,\,:,;,<,=,>,?,@,[,],^,`,~,|,{,}"
S GMPLTXT=$$STRIP^XLFSTR($TR(GMPLTXT,GMPLPUNC," ")," ")
I GMPLTXT?.L1.(1.U1.L)!(GMPLTXT?1.L) S GMPLRSLT=1
Q GMPLRSLT
;
PAUSE ; Pause for user to process info
I $E(IOST,1,2)="C-" D
. N DIR,DTOUT,DIRUT,DUOUT,X,Y
. S DIR(0)="E" D ^DIR
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMPLX 13344 printed Nov 14, 2020@18:37:41 Page 2
GMPLX ; ISL/MKB,AJB,JER,TC -- Problem List Problem Utilities ;07/03/17 09:13
+1 ;;2.0;Problem List;**7,23,26,28,27,36,42,40,49**;Aug 25, 1994;Build 43
+2 ;
+3 ; External References
+4 ; DBIA 446 ^AUTNPOV(
+5 ; ICR 5679 $$IMPDATE^LEXU
+6 ; ICR 5699 $$ICDDATA^ICDXCODE,$$STATCHK^ICDXCODE
+7 ; ICR 5747 $$CSI/SAB^ICDEX
+8 ; DBIA 10060 ^VA(200
+9 ; DBIA 10006 ^DIC
+10 ; DBIA 10009 FILE^DICN
+11 ; DBIA 10013 EN^DIK
+12 ; DBIA 10013 IX1^DIK
+13 ; DBIA 10026 ^DIR
+14 ; DBIA 1609 CONFIG^LEXSET
+15 ; DBIA 10103 $$FMTE^XLFDT
+16 ; DBIA 10104 $$UP^XLFSTR
+17 ; DBIA 2742 GMPLX
+18 ;
SEARCH(X,Y,PROMPT,UNRES,VIEW) ; Search Lexicon for Problem X
+1 NEW DIC
if '$LENGTH($GET(VIEW))
SET VIEW="CLF"
DO CONFIG^LEXSET("GMPX",VIEW,DT)
+2 SET DIC("A")=$SELECT($LENGTH($GET(PROMPT)):PROMPT,1:"Select PROBLEM: ")
+3 SET DIC="^LEX(757.01,"
SET DIC(0)=$SELECT('$LENGTH($GET(X)):"A",1:"")_"EQM"
+4 if '$GET(UNRES)
SET LEXUN=0
DO ^DIC
+5 IF +Y>1
Begin DoDot:1
+6 NEW CODE,SRC
+7 SET X=$PIECE(Y,U,2)
+8 DO EXP2CODE(+Y,.SRC,.CODE)
+9 IF (SRC["SNOMED")!(SRC["VHAT")
SET (X,$PIECE(Y,U,2))=X_" ("_$SELECT(SRC["SNOMED":"SCT",1:"VHAT")_" "_CODE_")"
SET Y(1)=$$GETDX(CODE,SRC)
End DoDot:1
+10 QUIT
+11 ;
PROVNARR(X,CL) ; Returns IFN ^ Text of Narrative (#9999999.27)
+1 NEW DIC,Y,DLAYGO,DD,DO,DA
if $LENGTH(X)>245
SET X=$EXTRACT(X,1,245)
+2 SET DIC="^AUTNPOV("
SET DIC(0)="L"
SET DLAYGO=9999999.27
SET (DA,Y)=0
+3 FOR
SET DA=$ORDER(^AUTNPOV("B",$EXTRACT(X,1,30),DA))
if DA'>0
QUIT
IF $PIECE(^AUTNPOV(DA,0),U)=X
SET Y=DA_U_X
QUIT
+4 IF '(+Y)
KILL DA,Y
DO FILE^DICN
if Y'>0
SET Y=U_X
IF Y>0
IF CL>1
SET ^AUTNPOV(+Y,757)=CL
+5 QUIT $PIECE(Y,U,1,2)
+6 ;
PROBTEXT(IFN) ; Returns Display Text
+1 NEW X,Y,ICD,SCTC,GMPL0,GMPL800,GMPL802,GMPLEXP,GMPLPOV,GMPLSO,GMPLTXT,GMPLDT,GMPLCSYS,GMPLILBL
+2 SET GMPL0=$GET(^AUPNPROB(IFN,0))
SET GMPL800=$GET(^(800))
SET GMPL802=$GET(^(802))
+3 IF '$LENGTH(GMPL0)
SET X=""
GOTO PROBTX
+4 SET GMPLDT=$SELECT(+$PIECE(GMPL802,U,1):$PIECE(GMPL802,U,1),1:$PIECE(GMPL0,U,8))
SET GMPLCSYS=$SELECT($PIECE(GMPL802,U,2)]"":$PIECE(GMPL802,U,2),1:$$SAB^ICDEX($$CSI^ICDEX(80,+GMPL0),GMPLDT))
+5 SET GMPLILBL=$SELECT(GMPLCSYS="10D":"ICD-10-CM ",1:"ICD-9-CM ")
+6 SET ICD=$PIECE($$ICDDATA^ICDXCODE(GMPLCSYS,+GMPL0,GMPLDT,"I"),U,2)
SET SCTC=$PIECE(GMPL800,U)
+7 SET Y=$PIECE($GET(^AUPNPROB(+IFN,0)),U,5)
SET X=$PIECE($GET(^AUTNPOV(+Y,0)),U)
+8 SET GMPLEXP=$$EP(IFN)
SET GMPLSO=$$CS(X)
SET GMPLPOV=$$PT(X,GMPLSO)
+9 SET GMPLTXT=GMPLPOV
if $LENGTH(GMPLEXP)
SET GMPLTXT=GMPLTXT_" ("_GMPLEXP_")"
+10 ;S:$L(GMPLSO)&(GMPLSO'["SNOMED") GMPLTXT=GMPLTXT_" "_GMPLSO
+11 if GMPLTXT["*"
SET GMPLTXT=$TRANSLATE(GMPLTXT,"*","")
+12 ;S:$L(GMPLTXT) GMPLTXT=GMPLTXT_" ("_$$HFP^GMPLUTL4_","_$$PTR^GMPLUTL4_")"
+13 if $LENGTH(GMPLTXT)
SET GMPLTXT=GMPLTXT_$SELECT($LENGTH($GET(ICD))&('$LENGTH($GET(SCTC))):" ("_GMPLILBL_$GET(ICD)_")",$LENGTH($GET(SCTC)):" (SCT "_$GET(SCTC)_")",1:"")
+14 if $LENGTH(GMPLTXT)
SET X=GMPLTXT
PROBTX QUIT X
PROBNARR(IFN) ; Returns Provider Narrative
+1 NEW X,Y
SET Y=$PIECE($GET(^AUPNPROB(+IFN,0)),U,5)
SET X=$PIECE($GET(^AUTNPOV(+Y,0)),U)
+2 QUIT X
CS(X) ; Problem Codes
+1 NEW GMPLSAB,GMPLSO
SET GMPLSO=""
SET X=$GET(X)
if X'["("
QUIT ""
+2 FOR GMPLSAB="ICD-","CPT-","DSM-","HCPCS","NANDA","NIC","NOC","LOINC","SNOMED","OMAHA","SCT"
if $GET(X)[("("_GMPLSAB)
SET GMPLSO="("_GMPLSAB_$PIECE(X,("("_GMPLSAB),2,299)
if $LENGTH(GMPLSO)
QUIT
+3 IF $LENGTH(GMPLSO)
SET X=GMPLSO
QUIT X
+4 FOR GMPLSAB="ACR","AI/RHEUM","CONGRESS","COSTAR","COSTART","CRISP","DODFAC"
if $GET(X)[("("_GMPLSAB)
SET GMPLSO="("_GMPLSAB_$PIECE(X,("("_GMPLSAB),2,299)
if $LENGTH(GMPLSO)
QUIT
+5 IF $LENGTH(GMPLSO)
SET X=GMPLSO
QUIT X
+6 FOR GMPLSAB="DORLAND","DXPLAIN","HHCC","MCMASTER","META","MTF","MeSH","RVC","TITLE 38","UMDNS","UWA"
if $GET(X)[("("_GMPLSAB)
SET GMPLSO="("_GMPLSAB_$PIECE(X,("("_GMPLSAB),2,299)
if $LENGTH(GMPLSO)
QUIT
+7 IF $LENGTH(GMPLSO)
SET X=GMPLSO
QUIT X
+8 QUIT ""
EP(X) ; Exposures
+1 NEW GMPLSC
SET X=+($GET(X))
DO SCS^GMPLX1(+X,.GMPLSC)
SET X=$GET(GMPLSC(1))
QUIT X
PT(X,C) ; Problem Text (only)
+1 NEW GMPLTERM,GMPLSO
SET GMPLTERM=$GET(X)
SET GMPLSO=$GET(C)
+2 if $LENGTH(GMPLSO)&(GMPLTERM[GMPLSO)
SET GMPLTERM=$PIECE(GMPLTERM,GMPLSO,1)
SET GMPLTERM=$$TRIM(GMPLTERM)
+3 if $LENGTH(GMPLTERM)
SET X=GMPLTERM
QUIT X
TRIM(X) ; Trim Spaces and "*"
+1 SET X=$GET(X)
FOR
if $EXTRACT(X,$LENGTH(X))'=" "
QUIT
SET X=$EXTRACT(X,1,($LENGTH(X)-1))
+2 FOR
if $EXTRACT(X,$LENGTH(X))'="*"
QUIT
SET X=$EXTRACT(X,1,($LENGTH(X)-1))
+3 FOR
if $EXTRACT(X,$LENGTH(X))'=" "
QUIT
SET X=$EXTRACT(X,1,($LENGTH(X)-1))
+4 FOR
if $EXTRACT(X,1)'=" "
QUIT
SET X=$EXTRACT(X,2,$LENGTH(X))
+5 QUIT X
WRAP(PROB,MAX,TEXT) ; Splits Text into TEXT array
+1 NEW I,J
SET J=0
KILL TEXT
IF $LENGTH(PROB)'>MAX
SET J=J+1
SET TEXT(J)=PROB
GOTO WRQ
WR0 ; Loop for Remaining Text
+1 SET I=$FIND(PROB," ")
IF ('I)!(I>(MAX+2))
SET J=J+1
SET TEXT(J)=$EXTRACT(PROB,1,MAX)
SET PROB=$EXTRACT(PROB,MAX+1,999)
+2 IF $LENGTH(PROB)>MAX
FOR I=(MAX+1):-1:1
IF $EXTRACT(PROB,I)=" "
SET J=J+1
SET TEXT(J)=$EXTRACT(PROB,1,I-1)
SET PROB=$EXTRACT(PROB,I+1,999)
QUIT
+3 if $LENGTH(PROB)>MAX
GOTO WR0
+4 if $LENGTH(PROB)
SET J=J+1
SET TEXT(J)=PROB
WRQ ; Quit Wrap
+1 SET TEXT=J
+2 QUIT
+3 ;
NOS(GMPLCSYS,GMPLDT) ; Return PTR ^ 799.9 or PTR ^ R69 ICD code
+1 NEW GMPIMPDT
SET GMPIMPDT=$$IMPDATE^LEXU("10D")
+2 if '$DATA(GMPLDT)
SET GMPLDT=DT
+3 if '$DATA(GMPLCSYS)
SET GMPLCSYS=$SELECT(GMPLDT<GMPIMPDT:"ICD",1:"10D")
+4 QUIT $SELECT(GMPLCSYS="10D":+$$ICDDATA^ICDXCODE(GMPLCSYS,"R69.",GMPLDT,"E")_"^R69.",1:+$$ICDDATA^ICDXCODE(GMPLCSYS,"799.9",GMPLDT,"E")_"^799.9")
+5 ;
SEL(HELP) ; Select List of Problems
+1 NEW X,Y,DIR,MAX,DTOUT
SET MAX=+$GET(^TMP("GMPL",$JOB,0))
IF MAX'>0
QUIT "^"
+2 SET DIR(0)="LAO^1:"_MAX
SET DIR("A")="Select Problem(s)"
+3 if MAX>1
SET DIR("A")=DIR("A")_" (1-"_MAX_"): "
+4 if MAX'>1
SET DIR("A")=DIR("A")_": "
SET DIR("B")=1
+5 SET DIR("?")="Enter the problems you wish to "
+6 SET DIR("?")=DIR("?")_$SELECT($LENGTH(HELP):HELP,1:"act on")_", as a range or list of numbers"
+7 DO ^DIR
IF $DATA(DTOUT)!(X="")
SET Y="^"
+8 QUIT Y
+9 ;
SEL1(HELP) ; Select 1 Problem
+1 NEW X,Y,DIR,MAX,DTOUT
SET MAX=+$GET(^TMP("GMPL",$JOB,0))
IF MAX'>0
QUIT "^"
+2 SET DIR(0)="NAO^1:"_MAX_":0"
SET DIR("A")="Select Problem"
+3 if MAX>1
SET DIR("A")=DIR("A")_" (1-"_MAX_"): "
+4 if MAX'>1
SET DIR("A")=DIR("A")_": "
SET DIR("B")=1
+5 SET DIR("?")="Enter the number of the problem you wish to "
+6 SET DIR("?")=DIR("?")_$SELECT($LENGTH(HELP):HELP,1:"act on")
+7 DO ^DIR
IF $DATA(DTOUT)!(X="")
SET Y="^"
+8 QUIT Y
+9 ;
DUPL(DFN,TERM,TEXT) ; Check for Duplicates
+1 NEW DA,IFN,GMPOTHR,GMPNOW
SET DA=0
SET TEXT=$$UP^XLFSTR($SELECT(TEXT["SCT":$PIECE(TEXT," (SCT"),1:TEXT))
+2 IF '$DATA(^AUPNPROB("AC",DFN))
GOTO DUPLX
+3 SET GMPNOW=$EXTRACT($$NOW^XLFDT,1,7)
+4 SET GMPOTHR=$SELECT(GMPNOW<($$IMPDATE^LEXU("10D")):"799.9",1:"R69.")
+5 FOR IFN=0:0
SET IFN=$ORDER(^AUPNPROB("AC",DFN,IFN))
if IFN'>0
QUIT
Begin DoDot:1
+6 NEW PICDOLD,PICDNEW,NODE0,NODE1,NODE800,NODE802,NODE803,SCTD,PROVNAR,EXPTXT,GMPSRC,GMPCODE,GMPLDT,GMPLCSYS
+7 SET NODE0=$GET(^AUPNPROB(IFN,0))
SET NODE1=$GET(^(1))
SET NODE800=$GET(^(800))
SET NODE802=$GET(^(802))
SET NODE803=$GET(^(803,0))
if $PIECE(NODE1,U,2)="H"
QUIT
+8 SET GMPLDT=$SELECT(+$PIECE(NODE802,U,1):$PIECE(NODE802,U,1),1:$PIECE(NODE0,U,8))
SET GMPLCSYS=$SELECT($PIECE(NODE802,U,2)]"":$PIECE(NODE802,U,2),1:$$SAB^ICDEX($$CSI^ICDEX(80,+NODE0),GMPLDT))
+9 SET PICDOLD=$PIECE($$ICDDATA^ICDXCODE(GMPLCSYS,+NODE0,GMPLDT,"I"),U,2)
+10 DO EXP2CODE(TERM,.GMPSRC,.GMPCODE)
+11 SET ICDNEW=$SELECT(GMPSRC="SNOMED CT":$$GETDX(GMPCODE,GMPSRC),1:GMPCODE)
+12 SET PICDNEW=$PIECE(ICDNEW,"/")
+13 ;Compare problems with SNOMED CT concept codes & ICD code(s) only
+14 IF +NODE800
IF (GMPSRC="SNOMED CT")
IF (+$GET(GMPCODE)>0)
IF ($LENGTH(ICDNEW))
Begin DoDot:2
+15 ;if SCT concepts & primary + multiple ICD targets match => dup
+16 IF $PIECE(NODE803,U,4)>0
IF ICDNEW["/"
Begin DoDot:3
+17 NEW I,J,SICDNEW
SET J=0
FOR I=2:1:$LENGTH(ICDNEW,"/")
Begin DoDot:4
+18 SET J=J+1
SET SICDNEW(J)=$PIECE(ICDNEW,"/",I)
End DoDot:4
+19 NEW T
FOR T=1:1:J
Begin DoDot:4
+20 NEW IEN
SET IEN=0
FOR
SET IEN=$ORDER(^AUPNPROB(IFN,803,IEN))
if '+IEN
QUIT
Begin DoDot:5
+21 IF +NODE800=GMPCODE
IF (PICDOLD=PICDNEW)
IF $PIECE($GET(^AUPNPROB(IFN,803,IEN,0)),U)=SICDNEW(T)
SET DA=IFN
QUIT
End DoDot:5
End DoDot:4
End DoDot:3
+22 ;if SCT concept codes match => dup
+23 IF '$TEST
IF ICDNEW=GMPOTHR!(PICDNEW=GMPOTHR)
Begin DoDot:3
+24 IF +NODE800=GMPCODE
SET DA=IFN
QUIT
End DoDot:3
+25 ;if SCT concepts & primary ICD diagnosis match => dup
+26 IF '$TEST
IF +NODE800=GMPCODE
IF (PICDOLD=PICDNEW)
SET DA=IFN
QUIT
End DoDot:2
QUIT
+27 ;Compare legacy problems with ICD codes only
+28 IF '$TEST
IF +NODE0
IF '$LENGTH($GET(NODE800))
IF (GMPSRC["ICD")
IF (+$GET(GMPCODE)>0)
Begin DoDot:2
+29 ;if Exprs match => dup
+30 IF TERM>1&(+NODE1=TERM)
SET DA=IFN
QUIT
+31 ;if Text matches Expr from old => dup
+32 DO LOOK^LEXA("`"_+NODE1)
+33 SET EXPTXT=$PIECE($GET(LEX("LIST",1)),U,2)
+34 IF LEX>1&(TEXT=$$UP^XLFSTR($SELECT(EXPTXT["*":$PIECE(EXPTXT," *"),1:EXPTXT)))
SET DA=IFN
QUIT
+35 ;if Text matches Prov Narr of old => dup
+36 SET PROVNAR=$SELECT($PIECE(NODE0,U,5)]"":$PIECE(^AUTNPOV($PIECE(NODE0,U,5),0),U),1:"")
+37 IF TEXT=$$UP^XLFSTR($SELECT(PROVNAR["SNOMED":$PIECE(PROVNAR," (SN"),PROVNAR[" *":$PIECE(PROVNAR,"*"),1:PROVNAR))
SET DA=IFN
QUIT
+38 ;if prim ICD of new = prim ICD of old => dup
+39 IF PICDOLD'=GMPOTHR
IF (PICDNEW'=GMPOTHR)
IF (PICDOLD=PICDNEW)
SET DA=IFN
QUIT
End DoDot:2
End DoDot:1
if DA>0
QUIT
DUPLX QUIT DA
+1 ;
DUPLOK(IFN) ; Ask if Dup OK
+1 NEW DIR,X,Y,GMPL0,GMPL1,DATE,PROV
SET DIR(0)="YA"
SET GMPL0=$GET(^AUPNPROB(IFN,0))
SET GMPL1=$GET(^(1))
+2 SET DIR("A")="Are you sure you want to continue? "
SET DIR("B")="NO"
+3 SET DIR("?",1)="Enter YES if you want to duplicate this problem on this patient's list;"
SET DIR("?")="press <return> to re-enter the problem name."
+4 WRITE $CHAR(7),!!,">>> "_$$PROBTEXT(IFN),!?5,"is already an "
+5 WRITE $SELECT($PIECE(GMPL0,U,12)="I":"IN",1:"")_"ACTIVE problem on this patient's list!",!
+6 SET PROV=+$PIECE(GMPL1,U,5)
if PROV
WRITE !?5,"Provider: "_$PIECE($GET(^VA(200,PROV,0)),U)_" ("_$PIECE($$SERVICE^GMPLX1(PROV),U,2)_")"
+7 IF $PIECE(GMPL0,U,12)="A"
WRITE !?8,"Onset: "
SET DATE=$PIECE(GMPL0,U,13)
+8 IF $PIECE(GMPL0,U,12)="I"
WRITE !?5,"Resolved: "
SET DATE=$PIECE(GMPL1,U,7)
+9 WRITE $SELECT(DATE>0:$$FMTE^XLFDT(DATE),1:"unspecified"),!
+10 DO ^DIR
WRITE !
+11 QUIT +Y
+12 ;
LOCKED() ; Return Lock Msg
+1 QUIT "This problem is currently being edited by another user!"
+2 ;
SURE() ; Ask to Delete
+1 ; Returns 1 if YES, else 0
+2 NEW DIR,X,Y
SET DIR(0)="YA"
SET DIR("B")="NO"
+3 SET DIR("?")="Enter YES to remove this value or NO to leave it unchanged."
+4 SET DIR("A")="Are you sure you want to remove this value? "
DO ^DIR
+5 QUIT +Y
+6 ;
EXTDT(DATE) ; Format Date as MM/DD/YY
+1 NEW X,MM,DD,YY,YYY
SET X=""
SET DATE=$PIECE(DATE,".")
if 'DATE
QUIT ""
+2 SET MM=+$EXTRACT(DATE,4,5)
SET DD=+$EXTRACT(DATE,6,7)
SET YY=$EXTRACT(DATE,2,3)
SET YYY=$EXTRACT(DATE,1,3)
+3 if MM
SET X=MM_"/"
if DD
SET X=X_DD_"/"
SET X=$SELECT($LENGTH(X):X_YY,1:1700+YYY)
+4 QUIT X
+5 ;
AUDIT(DATA,OLD) ; Make Entry in Audit File
+1 ; DATA = string for 0-node
+2 ; OLD = string for 1-node
+3 ; = 0-node from reform/react problem
+4 NEW DA,DD,DO,DIC,X,Y,DIK,DLAYGO
+5 SET DIC="^GMPL(125.8,"
SET DIC(0)="L"
SET X=$PIECE(DATA,U)
SET DLAYGO=125.8
+6 DO FILE^DICN
if +Y'>0
QUIT
SET DA=+Y
SET DIK="^GMPL(125.8,"
+7 SET ^GMPL(125.8,DA,0)=DATA
DO IX1^DIK
+8 if $LENGTH(OLD)
SET ^GMPL(125.8,DA,1)=OLD
+9 QUIT
+10 ;
DTMOD(DA) ; Update Date Modified
+1 NEW DIE,DR
+2 SET DR=".03///TODAY"
SET DIE="^AUPNPROB("
+3 DO ^DIE
+4 ; broadcast problem change events
+5 NEW GMPIFN,DFN,X
+6 SET GMPIFN=DA
SET DFN=+$PIECE($GET(^AUPNPROB(DA,0)),U,2)
+7 SET X=+$ORDER(^ORD(101,"B","GMPL EVENT",0))_";ORD(101,"
if X
DO EN1^XQOR
+8 QUIT
+9 ;
MSG() ; ListMan Msg Bar
+1 QUIT "+ Next Screen - Prev Screen ?? More actions"
+2 ;
KILL ; Clean-Up Vars
+1 KILL X,Y,DIC,DIE,DR,DA,DUOUT,DTOUT,GMPQUIT,GMPRT,GMPSAVED,GMPIFN,GMPLNO,GMPLNUM,GMPLSEL,GMPREBLD,GMPI,GMPLSLST,GMPLJUMP
+2 QUIT
+3 ;
CODESTS(PROB,ADATE) ;check status of ICD
+1 ; Input:
+2 ; PROB = pointer to the PROBLEM (#9000011) file
+3 ; ADATE = FM date on which to check the status (opt.)
+4 ;
+5 ; Output:
+6 ; 1 = ACTIVE on the date passed or current date
+7 ; 0 = INACTIVE on the date passed or current date
+8 ;
+9 IF '$GET(ADATE)
SET ADATE=DT
+10 IF '$DATA(^AUPNPROB(PROB,0))
QUIT 0
+11 NEW GMPL0,GMPL802,GMPLCSYS,GMPLCPTR,GMPLICD
SET GMPL0=$GET(^AUPNPROB(PROB,0))
SET GMPL802=$GET(^(802))
+12 SET GMPLCPTR=$$CSI^ICDEX(80,+GMPL0)
SET GMPLCSYS=$SELECT($PIECE(GMPL802,U,2)]"":$PIECE(GMPL802,U,2),1:$$SAB^ICDEX(GMPLCPTR,ADATE))
+13 SET GMPLICD=$PIECE($$ICDDATA^ICDXCODE(GMPLCSYS,+GMPL0,ADATE,"I"),U,2)
+14 QUIT +$$STATCHK^ICDXCODE(GMPLCPTR,GMPLICD,ADATE)
EXP2CODE(X,GMPSRC,GMPCODE) ; Resolve SOURCE and CODE from Expression
+1 NEW LEX,SRCCODE,GMI
SET GMI=0
SET (GMPSRC,GMPCODE)=""
+2 DO INFO^LEXA(X,DT)
+3 FOR
SET GMI=$ORDER(LEX("SEL","SRC",GMI))
if +GMI'>0
QUIT
Begin DoDot:1
+4 SET SRCCODE=$PIECE($GET(LEX("SEL","SRC",GMI)),U,1,2)
+5 IF $PIECE(SRCCODE,U)["SNOMED CT"!($PIECE(SRCCODE,U)["VHAT")!($PIECE(SRCCODE,U)["ICD")
SET GMPSRC=$PIECE(SRCCODE,U)
SET GMPCODE=$PIECE(SRCCODE,U,2)
End DoDot:1
if ($GET(GMPSRC)]"")
QUIT
+6 QUIT
GETDX(CODE,CODESYS,GMPDT) ; Get ICD associated with SCT or VHAT Code
+1 NEW LEX,GMPI,GMPY,GMPMPDEF,GMPIMPDT
SET GMPDT=$GET(GMPDT,$$DT^XLFDT)
+2 SET GMPY=0
SET GMPIMPDT=$$IMPDATE^LEXU("10D")
+3 SET GMPMPDEF=$SELECT(GMPDT<GMPIMPDT:"SCT2ICD",1:"SCT210D")
+4 IF CODESYS["VHAT"
SET GMPY=$$GETASSN^LEXTRAN1(CODE,"VHAT2ICD",GMPDT)
IF 1
+5 IF '$TEST
SET GMPY=$$GETASSN^LEXTRAN1(CODE,GMPMPDEF,GMPDT)
+6 IF $SELECT(+GMPY'>0:1,+$PIECE(GMPY,U,2)'>0:1,+LEX'>0:1,1:0)
SET GMPY=$SELECT(GMPDT<GMPIMPDT:"799.9",1:"R69.")
GOTO GETDXX
+7 SET (GMPI,GMPY)=0
+8 FOR
SET GMPI=$ORDER(LEX(GMPI))
if +GMPI'>0
QUIT
Begin DoDot:1
+9 NEW ICD
+10 SET ICD=$ORDER(LEX(GMPI,""))
+11 IF ICD]""
SET GMPY=$SELECT(GMPY'=0:GMPY_"/",1:"")_ICD
End DoDot:1
+12 IF GMPY'["."
SET GMPY=GMPY_"."
GETDXX QUIT GMPY
PAD(GMPX,GMPL) ; Pads string to specified length
+1 NEW GMPY
+2 SET GMPY=""
SET $PIECE(GMPY," ",(GMPL-$LENGTH(GMPX))+1)=""
+3 QUIT GMPY
GETEXIEN(GMPLSCTC,GMPLSCTD) ; Get Lexicon Expression IEN for SNOMED term
+1 NEW GMPLSYN,GMPLDT,GMPLRSLT,GMPLIEN,GMPLTYP,GMPLQT,GMPLNUM
+2 IF '$DATA(GMPLSCTC)!('$DATA(GMPLSCTD))
SET GMPLIEN="-1^Missing "_$SELECT('$DATA(GMPLSCTC):"SNOMED CT Concept ID",1:"SNOMED CT Designation ID")
GOTO GETEXQT
+3 SET GMPLDT=$$DT^XLFDT
SET (GMPLTYP,GMPLNUM,GMPLQT)=""
+4 SET GMPLRSLT=$$GETSYN^LEXTRAN1("SCT",GMPLSCTC,GMPLDT,"GMPLSYN",1,1)
+5 IF +GMPLRSLT<0
SET GMPLIEN=GMPLRSLT
GOTO GETEXQT
+6 FOR
SET GMPLTYP=$ORDER(GMPLSYN(GMPLTYP))
if GMPLTYP=""!(GMPLQT)
QUIT
Begin DoDot:1
+7 IF GMPLTYP="S"
Begin DoDot:2
+8 FOR
SET GMPLNUM=$ORDER(GMPLSYN(GMPLTYP,GMPLNUM))
if GMPLNUM=""!(GMPLQT)
QUIT
Begin DoDot:3
+9 IF $PIECE(GMPLSYN(GMPLTYP,GMPLNUM),U,3)=GMPLSCTD
SET GMPLIEN=$PIECE(GMPLSYN(GMPLTYP,GMPLNUM),U,2)
SET GMPLQT=1
QUIT
End DoDot:3
+10 if GMPLQT
QUIT
End DoDot:2
+11 IF '$TEST
IF $PIECE(GMPLSYN(GMPLTYP),U,3)=GMPLSCTD
SET GMPLIEN=$PIECE(GMPLSYN(GMPLTYP),U,2)
SET GMPLQT=1
QUIT
End DoDot:1
+12 IF GMPLQT=""
SET GMPLIEN="-1^Cannot find Expression IEN"
GETEXQT QUIT GMPLIEN
STRIPSPC(GMPLTXT) ; Strip string of spaces and convert to all uppercase for comparison
+1 NEW GMPLSTR,GMPLCHAR
SET GMPLCHAR=" "
+2 SET GMPLSTR=$$UP^XLFSTR($$STRIP^XLFSTR(GMPLTXT,GMPLCHAR))
+3 QUIT GMPLSTR
+4 ;
MIXLOWCS(GMPLTXT) ; Check for mix/lower case
+1 NEW GMPLRSLT,GMPLPUNC
SET GMPLRSLT=0
+2 SET GMPLPUNC=" ,!,"",#,$,%,&,',(,),*,+,-,,,_,.,/,\,:,;,<,=,>,?,@,[,],^,`,~,|,{,}"
+3 SET GMPLTXT=$$STRIP^XLFSTR($TRANSLATE(GMPLTXT,GMPLPUNC," ")," ")
+4 IF GMPLTXT?.L1.(1.U1.L)!(GMPLTXT?1.L)
SET GMPLRSLT=1
+5 QUIT GMPLRSLT
+6 ;
PAUSE ; Pause for user to process info
+1 IF $EXTRACT(IOST,1,2)="C-"
Begin DoDot:1
+2 NEW DIR,DTOUT,DIRUT,DUOUT,X,Y
+3 SET DIR(0)="E"
DO ^DIR
End DoDot:1
+4 QUIT
