source: FOIAVistA/tag/r/PROBLEM_LIST-GMPL/GMPLX.m

Last change on this file was 636, checked in by George Lilly, 14 years ago

WorldVistAEHR overlayed on FOIAVistA
File size: 7.0 KB
Line 
1GMPLX ; SLC/MKB/AJB -- Problem List Problem Utilities ; 02/27/2004
2 ;;2.0;Problem List;**7,23,26,28,27**;Aug 25, 1994;Build 1
3 ;
4 ; External References
5 ; DBIA 446 ^AUTNPOV(
6 ; DBIA 10082 ^ICD9("BA"
7 ; DBIA 10060 ^VA(200
8 ; DBIA 10006 ^DIC
9 ; DBIA 10009 FILE^DICN
10 ; DBIA 10013 EN^DIK
11 ; DBIA 10013 IX1^DIK
12 ; DBIA 10026 ^DIR
13 ; DBIA 1609 CONFIG^LEXSET
14 ; DBIA 10103 $$FMTE^XLFDT
15 ; DBIA 10104 $$UP^XLFSTR
16 ; DBIA 2742 GMPLX
17 ; DBIA 3991 $$STATCHK^ICDAPIU
18 ;
19SEARCH(X,Y,PROMPT,UNRES,VIEW) ; Search Lexicon for Problem X
20 N DIC S:'$L($G(VIEW)) VIEW="PL1" D CONFIG^LEXSET("GMPL",VIEW,DT)
21 S DIC("A")=$S($L($G(PROMPT)):PROMPT,1:"Select PROBLEM: ")
22 S DIC="^LEX(757.01,",DIC(0)=$S('$L($G(X)):"A",1:"")_"EQM"
23 S:'$G(UNRES) LEXUN=0 D ^DIC S:+Y>1 X=$P(Y,U,2)
24 Q
25 ;
26PROVNARR(X,CL) ; Returns IFN ^ Text of Narrative (#9999999.27)
27 N DIC,Y,DLAYGO,DD,DO,DA S:$L(X)>80 X=$E(X,1,80)
28 S DIC="^AUTNPOV(",DIC(0)="L",DLAYGO=9999999.27,(DA,Y)=0
29 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
30 I '(+Y) K DA,Y D FILE^DICN S:Y'>0 Y=U_X I Y>0,CL>1 S ^AUTNPOV(+Y,757)=CL
31 Q $P(Y,U,1,2)
32 ;
33PROBTEXT(IFN) ; Returns Display Text
34 N X,Y,GMPLEXP,GMPLPOV,GMPLSO,GMPLTXT
35 S Y=$P($G(^AUPNPROB(+IFN,0)),U,5),X=$P($G(^AUTNPOV(+Y,0)),U)
36 S GMPLEXP=$$EP(IFN),GMPLSO=$$CS(X),GMPLPOV=$$PT(X,GMPLSO)
37 S GMPLTXT=GMPLPOV S:$L(GMPLEXP) GMPLTXT=GMPLTXT_" ("_GMPLEXP_")"
38 S:$L(GMPLSO) GMPLTXT=GMPLTXT_" "_GMPLSO
39 S:GMPLTXT["*" GMPLTXT=$TR(GMPLTXT,"*","")
40 ;S:$L(GMPLTXT) GMPLTXT=GMPLTXT_" ("_$$HFP^GMPLUTL4_","_$$PTR^GMPLUTL4_")"
41 S:$L(GMPLTXT) X=GMPLTXT Q X
42PROBNARR(IFN) ; Returns Provider Narrative
43 N X,Y S Y=$P($G(^AUPNPROB(+IFN,0)),U,5),X=$P($G(^AUTNPOV(+Y,0)),U)
44 Q X
45CS(X) ; Problem Codes
46 N GMPLSAB,GMPLSO S GMPLSO="" S X=$G(X) Q:X'["(" ""
47 F GMPLSAB="ICD-","CPT-","DSM-","HCPCS","NANDA","NIC","NOC","LOINC","SNOMED","OMAHA" S:$G(X)[("("_GMPLSAB) GMPLSO="("_GMPLSAB_$P(X,("("_GMPLSAB),2,299) Q:$L(GMPLSO)
48 I $L(GMPLSO) S X=GMPLSO Q X
49 F GMPLSAB="ACR","AI/RHEUM","CONGRESS","COSTAR","COSTART","CRISP","DODFAC" S:$G(X)[("("_GMPLSAB) GMPLSO="("_GMPLSAB_$P(X,("("_GMPLSAB),2,299) Q:$L(GMPLSO)
50 I $L(GMPLSO) S X=GMPLSO Q X
51 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)
52 I $L(GMPLSO) S X=GMPLSO Q X
53 Q ""
54EP(X) ; Exposures
55 N GMPLSC S X=+($G(X)) D SCS^GMPLX1(+X,.GMPLSC) S X=$G(GMPLSC(1)) Q X
56PT(X,C) ; Problem Text (only)
57 N GMPLTERM,GMPLSO S GMPLTERM=$G(X),GMPLSO=$G(C)
58 S:$L(GMPLSO)&(GMPLTERM[GMPLSO) GMPLTERM=$P(GMPLTERM,GMPLSO,1) S GMPLTERM=$$TRIM(GMPLTERM)
59 S:$L(GMPLTERM) X=GMPLTERM Q X
60TRIM(X) ; Trim Spaces and "*"
61 S X=$G(X) F Q:$E(X,$L(X))'=" " S X=$E(X,1,($L(X)-1))
62 F Q:$E(X,$L(X))'="*" S X=$E(X,1,($L(X)-1))
63 F Q:$E(X,$L(X))'=" " S X=$E(X,1,($L(X)-1))
64 F Q:$E(X,1)'=" " S X=$E(X,2,$L(X))
65 Q X
66WRAP(PROB,MAX,TEXT) ; Splits Text into TEXT array
67 N I,J S J=0 K TEXT I $L(PROB)'>MAX S J=J+1,TEXT(J)=PROB G WRQ
68WR0 ; Loop for Remaining Text
69 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)
70 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
71 G:$L(PROB)>MAX WR0
72 S:$L(PROB) J=J+1,TEXT(J)=PROB
73WRQ ; Quit Wrap
74 S TEXT=J
75 Q
76 ;
77NOS() ; Return PTR ^ 799.9 ICD code
78 N X S X=$O(^ICD9("BA",799.9,0)) Q (+X_"^799.9")
79 ;
80SEL(HELP) ; Select List of Problems
81 N X,Y,DIR,MAX S MAX=+$G(^TMP("GMPL",$J,0)) I MAX'>0 Q "^"
82 S DIR(0)="LAO^1:"_MAX,DIR("A")="Select Problem(s)"
83 S:MAX>1 DIR("A")=DIR("A")_" (1-"_MAX_"): "
84 S:MAX'>1 DIR("A")=DIR("A")_": ",DIR("B")=1
85 S DIR("?")="Enter the problems you wish to "
86 S DIR("?")=DIR("?")_$S($L(HELP):HELP,1:"act on")_", as a range or list of numbers"
87 D ^DIR I $D(DTOUT)!(X="") S Y="^"
88 Q Y
89 ;
90SEL1(HELP) ; Select 1 Problem
91 N X,Y,DIR,MAX S MAX=+$G(^TMP("GMPL",$J,0)) I MAX'>0 Q "^"
92 S DIR(0)="NAO^1:"_MAX_":0",DIR("A")="Select Problem"
93 S:MAX>1 DIR("A")=DIR("A")_" (1-"_MAX_"): "
94 S:MAX'>1 DIR("A")=DIR("A")_": ",DIR("B")=1
95 S DIR("?")="Enter the number of the problem you wish to "
96 S DIR("?")=DIR("?")_$S($L(HELP):HELP,1:"act on")
97 D ^DIR I $D(DTOUT)!(X="") S Y="^"
98 Q Y
99 ;
100DUPL(DFN,TERM,TEXT) ; Check's for Duplicate Entries
101 N DA,IFN,NODE0,NODE1 S DA=0,TEXT=$$UP^XLFSTR(TEXT)
102 I '$D(^AUPNPROB("C",TERM))!('$D(^AUPNPROB("AC",DFN))) Q DA
103 F IFN=0:0 S IFN=$O(^AUPNPROB("AC",DFN,IFN)) Q:IFN'>0 D Q:DA>0
104 . S NODE0=$G(^AUPNPROB(IFN,0)),NODE1=$G(^(1)) Q:$P(NODE1,U,2)="H"
105 . I TERM>1 S:+NODE1=TERM DA=IFN Q
106 . S:TEXT=$$UP^XLFSTR($P(^AUTNPOV($P(NODE0,U,5),0),U)) DA=IFN
107 Q DA
108 ;
109DUPLOK(IFN) ; Ask to Duplicate Problem
110 N DIR,X,Y,GMPL0,GMPL1,DATE,PROV S DIR(0)="YA",GMPL0=$G(^AUPNPROB(IFN,0)),GMPL1=$G(^(1))
111 S DIR("A")="Are you sure you want to continue? ",DIR("B")="NO"
112 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."
113 W $C(7),!!,">>> "_$$PROBTEXT(IFN),!?5,"is already an "
114 W $S($P(GMPL0,U,12)="I":"IN",1:"")_"ACTIVE problem on this patient's list!",!
115 S PROV=+$P(GMPL1,U,5) W:PROV !?5,"Provider: "_$P($G(^VA(200,PROV,0)),U)_" ("_$P($$SERVICE^GMPLX1(PROV),U,2)_")"
116 I $P(GMPL0,U,12)="A" W !?8,"Onset: " S DATE=$P(GMPL0,U,13)
117 I $P(GMPL0,U,12)="I" W !?5,"Resolved: " S DATE=$P(GMPL1,U,7)
118 W $S(DATE>0:$$FMTE^XLFDT(DATE),1:"unspecified"),!
119 D ^DIR W !
120 Q +Y
121 ;
122LOCKED() ; Returns Message that Problem is Locked
123 Q "This problem is currently being edited by another user!"
124 ;
125SURE() ; Ask to Delete
126 ; Returns 1 if YES, else 0
127 N DIR,X,Y S DIR(0)="YA",DIR("B")="NO"
128 S DIR("?")="Enter YES to remove this value or NO to leave it unchanged."
129 S DIR("A")="Are you sure you want to remove this value? " D ^DIR
130 Q +Y
131 ;
132EXTDT(DATE) ; Formats Date into MM/DD/YY
133 N X,MM,DD,YY,YYY S X="",DATE=$P(DATE,".") Q:'DATE ""
134 S MM=+$E(DATE,4,5),DD=+$E(DATE,6,7),YY=$E(DATE,2,3),YYY=$E(DATE,1,3)
135 S:MM X=MM_"/" S:DD X=X_DD_"/" S X=$S($L(X):X_YY,1:1700+YYY)
136 Q X
137 ;
138AUDIT(DATA,OLD) ; Makes Entry in Audit File
139 ; DATA = string for 0-node
140 ; OLD = string for 1-node
141 ; = 0-node from reform/react problem
142 N DA,DD,DO,DIC,X,Y,DIK,DLAYGO
143 S DIC="^GMPL(125.8,",DIC(0)="L",X=$P(DATA,U),DLAYGO=125.8
144 D FILE^DICN Q:+Y'>0 S DA=+Y,DIK="^GMPL(125.8,"
145 S ^GMPL(125.8,DA,0)=DATA D IX1^DIK
146 S:$L(OLD) ^GMPL(125.8,DA,1)=OLD
147 Q
148 ;
149DTMOD(DA) ; Update Date Last Modified
150 N DIE,DR
151 S DR=".03///TODAY",DIE="^AUPNPROB("
152 D ^DIE
153 Q
154 ;
155MSG() ; List Manager Message Bar
156 Q "+ Next Screen - Prev Screen ?? More actions"
157 ;
158KILL ; Clean-Up Variables
159 K X,Y,DIC,DIE,DR,DA,DUOUT,DTOUT,GMPQUIT,GMPRT,GMPSAVED,GMPIFN,GMPLNO,GMPLNUM,GMPLSEL,GMPREBLD,GMPI,GMPLSLST,GMPLJUMP
160 Q
161 ;
162CODESTS(PROB,ADATE) ;check status of code associated with a problem
163 ; Input:
164 ; PROB = pointer to the PROBLEM (#9000011) file
165 ; ADATE = FM date on which to check the status of ICD9 code (opt.)
166 ;
167 ; Output:
168 ; 1 = ACTIVE on the date passed or current date if not passed
169 ; 0 = INACTIVE on the date passed or current date if not passed
170 ;
171 I '$G(ADATE) S ADATE=DT
172 I '$D(^AUPNPROB(PROB,0)) Q 0
173 S PROB=$P(^AUPNPROB(PROB,0),U)
174 Q +($$STATCHK^ICDAPIU($$CODEC^ICDCODE(+(PROB)),ADATE))
Note: See TracBrowser for help on using the repository browser.