source: WorldVistAEHR/trunk/r/PCE_PATIENT_CARE_ENCOUNTER-AUTN-EFDP-PX-VSIT--PXRM/PXCEPOV1.m@ 1800

Last change on this file since 1800 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR
File size: 5.4 KB
Line 
1PXCEPOV1 ;ISL/dee - Used to edit and display V POV ;8/31/05
2 ;;1.0;PCE PATIENT CARE ENCOUNTER;**134,149,124,170**;Aug 12, 1996
3 ;; ;
4 Q
5 ;
6 ;********************************
7 ;Special cases for display.
8 ;
9DNARRAT(PNAR) ;Provider Narrative for ICD-9
10 N PXCEPNAR,SNARR
11 I PNAR<0 Q ""
12 S PXCEPNAR=$P(^AUTNPOV(PNAR,0),"^")
13 I $G(VIEW)="B",$D(ENTRY)>0 D
14 . N DIC,DR,DA,DIQ,PXCEDIQ1
15 . ;S DIC=80
16 . ;S DR="3"
17 . S DA=$P(ENTRY(0),"^",1)
18 . ;S DIQ="PXCEDIQ1("
19 . ;S DIQ(0)="E"
20 . ;D EN^DIQ1
21 . S SNARR=$P($$ICDDX^ICDCODE(DA,$G(IDATE)),"^",4)
22 . ;S:$G(PXCEDIQ1(80,DA,3,"E"))=PXCEPNAR PXCEPNAR=""
23 . S:SNARR=PXCEPNAR PXCEPNAR=""
24 Q PXCEPNAR
25 ;
26DPRIMSEC(PRIMSEC) ;
27 I $G(VIEW)="B" Q $S(PRIMSEC="P":"PRIMARY",1:"")
28 Q $S(PRIMSEC="P":"PRIMARY",PRIMSEC="S":"SECONDARY",1:"")
29 ;
30 ;********************************
31 ;Special cases for edit.
32 ;
33ENARRAT(REQUIRED,ASK,DEFAULT,FILE,FIELD1,FIELD2) ;Provider Narrative -- Used by ALL V-Files with Prov. Nar.
34 ; REQUIRED 0 for not required
35 ; 1 for required
36 ; ASK 0 for do not ask
37 ; 1 for ask
38 ; 2 for ask only if there is already a value
39 ; DEFAULT 0 for do not default
40 ; 1 for do default
41 ; changed to 1 if REQUIRED is 1
42 ;
43 N PXKLAYGO,ASKING
44 S PXKLAYGO=""
45 S ASKING=ASK#2
46 S:REQUIRED DEFAULT=1
47 I PXCEKEYS["C" S ASKING=1
48ENARRAT1 ;
49 K DIR,DA,X,Y,C
50 S (X,Y)=""
51 I $P(PXCEAFTR($P(PXCETEXT,"~",1)),"^",$P(PXCETEXT,"~",2))'="" D
52 . N DIERR,PXCEDILF,PXCEEXT,PXCEINT
53 . S PXCEINT=$P(PXCEAFTR($P(PXCETEXT,"~",1)),"^",$P(PXCETEXT,"~",2))
54 . S PXCEEXT=$$EXTERNAL^DILFD(PXCEFILE,$P(PXCETEXT,"~",3),"",PXCEINT,"PXCEDILF")
55 . S (DIR("B"),X,Y)=$S('$D(DIERR):PXCEEXT,1:PXCEINT)
56 S DIR(0)="FAO^1:245"
57 S DIR("A")=$P(PXCETEXT,"~",4)
58 I $P(PXCETEXT,"~",8)]"" S DIR("?")=$P(PXCETEXT,"~",8)
59 E D
60 . S DIR("?",1)="This response must have at least 2 characters and no more than 245"
61 . S DIR("?",2)="characters and must not contain embedded uparrow."
62 . I REQUIRED S DIR("?")="This field is required."
63 . E S DIR("?")="This field is optional."
64 I ASK=2,(Y]"") S ASKING=1
65 I ASKING D ^DIR
66 K DIR,DA
67 I X="@" S Y="@"
68 E I $D(DTOUT)!$D(DUOUT) S PXCEEND=1 S:REQUIRED PXCEQUIT=1 Q
69 N PXCEX,PXCEY
70 I $E(Y,1)="=" S PXCEX=$E(PXCEIN01_" "_$E($P(Y,"^"),2,245),1,245)
71 E S PXCEX=Y
72 I DEFAULT,PXCEX="" S PXCEX=$$EXTTEXT^PXUTL1($P(PXCEAFTR(0),"^",1),REQUIRED,$G(FILE),$G(FIELD1),$G(FIELD2))
73 I ASKING D
74 . W !,PXCEX
75 I $L(PXCEX)=1,PXCEX'="@" W !,"Must be 2 to 245 characters." G ENARRAT1
76 I PXCEX="@"!(PXCEX=""),REQUIRED W !,"This field is required.",$C(7) G ENARRAT1
77 ;
78 I PXCEX="@"!(PXCEX="") S PXCEY=PXCEX
79 E S PXCEY=$$PROVNARR^PXAPI(PXCEX,PXCEFILE) I ASKING,+PXCEY'>0 W "??",$C(7) G ENARRAT1
80 E I +PXCEY'>0 S PXCEY=""
81 S $P(PXCEAFTR($P(PXCETEXT,"~",1)),"^",$P(PXCETEXT,"~",2))=$P(PXCEY,"^")
82 Q
83 ;
84EINJURY ;Date/Time of Injury
85 ;I not an injury code Q
86 N DIC,DR,DA,DIQ,PXCEDIQ1
87 S DIC=80
88 S DR=".01"
89 S DA=$P(PXCEAFTR(0),"^",1)
90 S DIQ="PXCEDIQ1("
91 S DIQ(0)="E"
92 D EN^DIQ1
93 I PXCEDIQ1(80,DA,.01,"E")'<800,PXCEDIQ1(80,DA,.01,"E")'>999.999 D E1201^PXCEPOV1(-1,-1,0)
94 Q
95 ;
96 ;********************************
97 ;Special cases for edit for Event Date and Time field number 1201
98 ; and other date and times.
99 ;
100E1201(REQTIME,BEFORE,AFTER,DEFAULT) ;
101 ;REQTIME is 1 if time is required,
102 ; 0 if time is optional
103 ; -1 if the date can be imprecise
104 ;BEFORE is the number of days before the visit that the date can
105 ; not be before or -1 for any amount before.
106 ;AFTER is the number of days after the visit that the date can
107 ; not be after or -1 for any amount. In any case the date
108 ; can not be later than today.
109 ;DEFAULT is the default date/time is there is not one in the file.
110 ; If it is -1 then NOW will be used as the default.
111 ; If it is 0 then TODAY will be used as the default.
112 N X1,X2,X,%Y,%H,%I,%
113 N PXCEVST S PXCEVST=$P(+^TMP("PXK",$J,"VST",1,0,"BEFORE"),".")
114 N PXCEBEF,PXCEAFT S (PXCEBEF,PXCEAFT)=""
115 I $D(AFTER)#2,AFTER'<0 D
116 . I AFTER=0 S PXCEAFT=PXCEVST+.9
117 . E D
118 .. S X1=DT
119 .. S X2=$P(+^TMP("PXK",$J,"VST",1,0,"BEFORE"),".")
120 .. D ^%DTC
121 .. I X'>AFTER S PXCEAFT=DT+.9
122 .. E D
123 ... S X1=$P(+^TMP("PXK",$J,"VST",1,0,"BEFORE"),".")
124 ... S X2=AFTER
125 ... D C^%DTC
126 ... S PXCEAFT=X+.9
127 I $D(BEFORE)#2,BEFORE'<0 D
128 . I BEFORE=0 S PXCEBEF=PXCEVST
129 . E D
130 .. S X1=$P(+^TMP("PXK",$J,"VST",1,0,"BEFORE"),".")
131 .. S X2=-BEFORE
132 .. D C^%DTC
133 .. S PXCEBEF=X
134 S DIR(0)="DO^"_PXCEBEF_":"_PXCEAFT_":ESP"
135 I $G(REQTIME)=1 S DIR(0)=DIR(0)_"RX"
136 E I $G(REQTIME)=-1 S DIR(0)=DIR(0)_"T"
137 E S DIR(0)=DIR(0)_"TX"
138 I $P(PXCEAFTR($P(PXCETEXT,"~",1)),"^",$P(PXCETEXT,"~",2))'="" S DIR("B")=$P(PXCEAFTR($P(PXCETEXT,"~",1)),"^",$P(PXCETEXT,"~",2))
139 E I ($D(DEFAULT)#2) D
140 . I DEFAULT>0 S DIR("B")=DEFAULT
141 . E I DEFAULT=0 S DIR("B")=DT
142 . E I DEFAULT=-1 D NOW^%DTC S DIR("B")=%
143 I $D(DIR("B"))#2 S Y=DIR("B") D DD^%DT S DIR("B")=Y
144 S DIR("A")=$P(PXCETEXT,"~",4)
145 S:$P(PXCETEXT,"~",8)]"" DIR("?")=$P(PXCETEXT,"~",8)
146 D ^DIR
147 K DIR,DA
148 I X="@" S Y="@"
149 E I $D(DTOUT)!$D(DUOUT) S PXCEEND=1 Q
150 S $P(PXCEAFTR($P(PXCETEXT,"~",1)),"^",$P(PXCETEXT,"~",2))=$P(Y,"^")
151 Q
152 ;
153ICDCODE ;enter ICD9 code using lexicon
154 ; DBIA # 1571 AND 1609
155 N CODE
156 K X
157 I +$G(PXCEAFTR(0))>0 D
158 . S CODE=$P(PXCEAFTR(0),"^")
159 . S X=$P($$ICDDX^ICDCODE(CODE,$G(PXCEAPDT)),"^",2)
160 D CONFIG^LEXSET("ICD",,$G(PXCEAPDT))
161 S DIC("A")="Select Diagnosis: "
162 S DIC="^LEX(757.01,",DIC(0)=$S('$L($G(X)):"A",1:"")_"EQM"
163 D ^DIC
164 I X="@" Q
165 I Y=-1 S DIRUT=-1 Q
166 S CODE=Y(1)
167 S Y=+$$ICDDX^ICDCODE(CODE)
168 Q
Note: See TracBrowser for help on using the repository browser.