- GMPLX ; ISL/MKB,AJB,JER,TC,PKR -- Problem List Problem Utilities ;03/30/2020
- ;;2.0;Problem List;**7,23,26,28,27,36,42,40,49,53**;Aug 25, 1994;Build 159
- ;
- ; External References
- ; DBIA 446 ^AUTNPOV(
- ; ICR 5679 $$IMPDATE^LEXU
- ; ICR 5747 $$CSI/SAB^ICDEX
- ; ICR 6953 $$PROVNARR^PXAPI
- ; 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 RESULT
- S RESULT=$$PROVNARR^PXAPI(X,9000011,CL)
- I $P(RESULT,U,1)=-1 S RESULT=$$PROVNARR^PXAPI("Invalid narrative passed",9000011)
- Q $P(RESULT,U,1)
- ;
- 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))
- S 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=$$CODEC^ICDEX(80,+GMPL0)
- S SCTC=$P(GMPL800,U,1)
- 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:GMPLTXT["*" GMPLTXT=$TR(GMPLTXT,"*","")
- 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 CODE
- S:'$D(GMPLDT) GMPLDT=DT
- S:'$D(GMPLCSYS) GMPLCSYS=$S(GMPLDT<3151001:"ICD",1:"10D")
- S CODE=$S(GMPLCSYS="10D":"R69.",1:"799.9")
- Q +$$CODEN^ICDEX(CODE,80)_U_CODE
- ;
- 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
- I '$D(^AUPNPROB("AC",DFN)) Q 0
- N CODE,CMAPL,ECODE,IND,MATCHIEN,MCODE,PROBIEN,RESULT
- N SCTCODE,SECCODE,SECMATCH,SOURCE,TEMP
- ;The rules for determining if there is a match are:
- ;
- ;1. For SCT problems mapped to multiple ICD diagnoses:
- ; If the SCT concept code, primary ICD diagnosis code, and secondary ICD
- ; diagnosis codes match that of a pre-existing problem, it's a
- ; duplicate.
- ;
- ;2. For SCT problems mapped to an unspecified ICD diagnosis (799.9 or
- ;R69) code:
- ; If the SCT concept code matches that of a pre-existing problem, it's
- ; a duplicate.
- ;
- ;3. For all other SCT problems, those mapped to a single primary ICD
- ;diagnosis:
- ; If the SCT concept code and primary ICD diagnosis code matches that
- ; of a pre-existing problem, it's a duplicate.
- ;
- S (MATCHIEN,PROBIEN)=0
- F Q:MATCHIEN>0 S PROBIEN=+$O(^AUPNPROB("AC",DFN,PROBIEN)) Q:PROBIEN=0 D
- . S SCTCODE=$P($G(^AUPNPROB(PROBIEN,800)),U,1)
- . I SCTCODE="" Q
- .;Skip Hidden Problems
- .;If there is no SCT code it is a legacy problem.
- . I $P(^AUPNPROB(PROBIEN,1),U,2)="H" Q
- .;
- .;SCT-ICD entry
- . D EXP2CODE(TERM,.SOURCE,.ECODE)
- . I SOURCE'="SNOMED CT" Q
- . I ECODE'=SCTCODE Q
- . K CMAPL
- . S RESULT=$$GETASSN^LEXTRAN1(SCTCODE,"SCT210D",DT,"CMAPL")
- .;No mapped code, so the match is because ECODE=SCTCODE
- . I +RESULT=0 S MATCHIEN=PROBIEN Q
- .;The primary code must match.
- . S MCODE=$O(CMAPL(1,""))
- . I MCODE="R69." S MATCHIEN=PROBIEN Q
- . S TEMP=^AUPNPROB(PROBIEN,0)
- . S CODE=$$CODEC^ICDEX(80,$P(TEMP,U,1))
- . I CODE'=MCODE Q
- .;All secondary codes must match.
- . S SECMATCH=1
- . F IND=2:1:CMAPL D
- .. S SECCODE=$O(CMAPL(2,""))
- .. I '$D(^AUPNPROB(PROBIEN,803,"B",SECCODE)) S SECMATCH=0
- . I SECMATCH S MATCHIEN=PROBIEN
- Q MATCHIEN
- ;
- 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() ; List Manager Msg Bar
- Q "+ Next Screen - Prev Screen ?? More actions"
- ;
- KILL ; Clean-Up variables
- 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 GMPLCPTR,GMPLSTAT
- S GMPLCPTR=$P(^AUPNPROB(PROB,0),U,1)
- S GMPLSTAT=+$$SAI^ICDEX(80,GMPLCPTR,ADATE)
- Q GMPLSTAT
- ;
- EXP2CODE(X,GMPSRC,GMPCODE) ; Resolve SOURCE,CODE and EXPRESSION
- ;from the Expressions file.
- N IND,GMI,LEX,SRCCODE
- 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 12192 printed Jan 18, 2025@03:31:42 Page 2
- 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
- +2 ;
- +3 ; External References
- +4 ; DBIA 446 ^AUTNPOV(
- +5 ; ICR 5679 $$IMPDATE^LEXU
- +6 ; ICR 5747 $$CSI/SAB^ICDEX
- +7 ; ICR 6953 $$PROVNARR^PXAPI
- +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 RESULT
- +2 SET RESULT=$$PROVNARR^PXAPI(X,9000011,CL)
- +3 IF $PIECE(RESULT,U,1)=-1
- SET RESULT=$$PROVNARR^PXAPI("Invalid narrative passed",9000011)
- +4 QUIT $PIECE(RESULT,U,1)
- +5 ;
- 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))
- +5 SET GMPLCSYS=$SELECT($PIECE(GMPL802,U,2)]"":$PIECE(GMPL802,U,2),1:$$SAB^ICDEX($$CSI^ICDEX(80,+GMPL0),GMPLDT))
- +6 SET GMPLILBL=$SELECT(GMPLCSYS="10D":"ICD-10-CM ",1:"ICD-9-CM ")
- +7 SET ICD=$$CODEC^ICDEX(80,+GMPL0)
- +8 SET SCTC=$PIECE(GMPL800,U,1)
- +9 SET Y=$PIECE($GET(^AUPNPROB(+IFN,0)),U,5)
- SET X=$PIECE($GET(^AUTNPOV(+Y,0)),U)
- +10 SET GMPLEXP=$$EP(IFN)
- SET GMPLSO=$$CS(X)
- SET GMPLPOV=$$PT(X,GMPLSO)
- +11 SET GMPLTXT=GMPLPOV
- if $LENGTH(GMPLEXP)
- SET GMPLTXT=GMPLTXT_" ("_GMPLEXP_")"
- +12 if GMPLTXT["*"
- SET GMPLTXT=$TRANSLATE(GMPLTXT,"*","")
- +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 CODE
- +2 if '$DATA(GMPLDT)
- SET GMPLDT=DT
- +3 if '$DATA(GMPLCSYS)
- SET GMPLCSYS=$SELECT(GMPLDT<3151001:"ICD",1:"10D")
- +4 SET CODE=$SELECT(GMPLCSYS="10D":"R69.",1:"799.9")
- +5 QUIT +$$CODEN^ICDEX(CODE,80)_U_CODE
- +6 ;
- 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 IF '$DATA(^AUPNPROB("AC",DFN))
- QUIT 0
- +2 NEW CODE,CMAPL,ECODE,IND,MATCHIEN,MCODE,PROBIEN,RESULT
- +3 NEW SCTCODE,SECCODE,SECMATCH,SOURCE,TEMP
- +4 ;The rules for determining if there is a match are:
- +5 ;
- +6 ;1. For SCT problems mapped to multiple ICD diagnoses:
- +7 ; If the SCT concept code, primary ICD diagnosis code, and secondary ICD
- +8 ; diagnosis codes match that of a pre-existing problem, it's a
- +9 ; duplicate.
- +10 ;
- +11 ;2. For SCT problems mapped to an unspecified ICD diagnosis (799.9 or
- +12 ;R69) code:
- +13 ; If the SCT concept code matches that of a pre-existing problem, it's
- +14 ; a duplicate.
- +15 ;
- +16 ;3. For all other SCT problems, those mapped to a single primary ICD
- +17 ;diagnosis:
- +18 ; If the SCT concept code and primary ICD diagnosis code matches that
- +19 ; of a pre-existing problem, it's a duplicate.
- +20 ;
- +21 SET (MATCHIEN,PROBIEN)=0
- +22 FOR
- if MATCHIEN>0
- QUIT
- SET PROBIEN=+$ORDER(^AUPNPROB("AC",DFN,PROBIEN))
- if PROBIEN=0
- QUIT
- Begin DoDot:1
- +23 SET SCTCODE=$PIECE($GET(^AUPNPROB(PROBIEN,800)),U,1)
- +24 IF SCTCODE=""
- QUIT
- +25 ;Skip Hidden Problems
- +26 ;If there is no SCT code it is a legacy problem.
- +27 IF $PIECE(^AUPNPROB(PROBIEN,1),U,2)="H"
- QUIT
- +28 ;
- +29 ;SCT-ICD entry
- +30 DO EXP2CODE(TERM,.SOURCE,.ECODE)
- +31 IF SOURCE'="SNOMED CT"
- QUIT
- +32 IF ECODE'=SCTCODE
- QUIT
- +33 KILL CMAPL
- +34 SET RESULT=$$GETASSN^LEXTRAN1(SCTCODE,"SCT210D",DT,"CMAPL")
- +35 ;No mapped code, so the match is because ECODE=SCTCODE
- +36 IF +RESULT=0
- SET MATCHIEN=PROBIEN
- QUIT
- +37 ;The primary code must match.
- +38 SET MCODE=$ORDER(CMAPL(1,""))
- +39 IF MCODE="R69."
- SET MATCHIEN=PROBIEN
- QUIT
- +40 SET TEMP=^AUPNPROB(PROBIEN,0)
- +41 SET CODE=$$CODEC^ICDEX(80,$PIECE(TEMP,U,1))
- +42 IF CODE'=MCODE
- QUIT
- +43 ;All secondary codes must match.
- +44 SET SECMATCH=1
- +45 FOR IND=2:1:CMAPL
- Begin DoDot:2
- +46 SET SECCODE=$ORDER(CMAPL(2,""))
- +47 IF '$DATA(^AUPNPROB(PROBIEN,803,"B",SECCODE))
- SET SECMATCH=0
- End DoDot:2
- +48 IF SECMATCH
- SET MATCHIEN=PROBIEN
- End DoDot:1
- +49 QUIT MATCHIEN
- +50 ;
- 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() ; List Manager Msg Bar
- +1 QUIT "+ Next Screen - Prev Screen ?? More actions"
- +2 ;
- KILL ; Clean-Up variables
- +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 GMPLCPTR,GMPLSTAT
- +12 SET GMPLCPTR=$PIECE(^AUPNPROB(PROB,0),U,1)
- +13 SET GMPLSTAT=+$$SAI^ICDEX(80,GMPLCPTR,ADATE)
- +14 QUIT GMPLSTAT
- +15 ;
- EXP2CODE(X,GMPSRC,GMPCODE) ; Resolve SOURCE,CODE and EXPRESSION
- +1 ;from the Expressions file.
- +2 NEW IND,GMI,LEX,SRCCODE
- +3 SET GMI=0
- SET (GMPSRC,GMPCODE)=""
- +4 DO INFO^LEXA(X,DT)
- +5 FOR
- SET GMI=$ORDER(LEX("SEL","SRC",GMI))
- if +GMI'>0
- QUIT
- Begin DoDot:1
- +6 SET SRCCODE=$PIECE($GET(LEX("SEL","SRC",GMI)),U,1,2)
- +7 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
- +8 QUIT
- +9 ;
- 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
- +1 ;
- PAD(GMPX,GMPL) ; Pads string to specified length
- +1 NEW GMPY
- +2 SET GMPY=""
- SET $PIECE(GMPY," ",(GMPL-$LENGTH(GMPX))+1)=""
- +3 QUIT GMPY
- +4 ;
- 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
- +1 ;
- 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
- +5 ;