source: FOIAVistA/trunk/r/PCE_PATIENT_CARE_ENCOUNTER-AUTN-EFDP-PX-VSIT--PXRM/PXCEVFI1.m@ 1757

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

initial load of FOIAVistA 6/30/08 version

File size: 3.7 KB
Line 
1PXCEVFI1 ;ISL/dee,esw - Routine to edit a visit or v-file entry ;8/3/04 10:32am
2 ;;1.0;PCE PATIENT CARE ENCOUNTER;**23,73,112,136,143,124,184**;Aug 12, 1996;Build 30
3 Q
4 ;
5EDIT ; -- edit the V-File stored in "AFTER"
6 N DIR,DA,X,Y,C,PXCEINP,PXCEIN01,PXCEEND,PXD
7 N PXCELINE,PXCETEXT,PXCEDIRB,PXCEMOD
8 N PXCEKEY,PXCEIKEY,PXCENKEY,PXMDCNT
9 W !
10 G:PXCECAT="VST"!(PXCECAT="APPM")!(PXCECAT="CSTP") REST
11 ;
12EDIT01 ;
13 I PXCECAT="CPT"!(PXCECAT="POV")!(PXCECAT="SK")!(PXCECAT="IMM") D SC^PXCEVFI2($P(^AUPNVSIT(PXCEVIEN,0),U,5))
14 S PXCETEXT=$P($T(FORMAT+1^@PXCECODE),";;",2)
15 K DIR,DA,X,Y,C,PXCEDIRB
16 I $P(PXCEAFTR(0),"^",1) D
17 . N DIEER,PXCEDILF,PXCEEXT
18 . S PXCEEXT=$$EXTERNAL^DILFD(PXCEFILE,.01,"",$P(PXCEAFTR(0),"^",1),"PXCEDILF")
19 . S PXCEDIRB=$S('$D(DIERR):PXCEEXT,1:$P(PXCEAFTR(0),"^",1))
20 E S PXCEDIRB=""
21 I $P(PXCETEXT,"~",7)]"" D
22 . D @$P(PXCETEXT,"~",7)
23 E D
24 . I PXCEDIRB'="" S DIR("B")=PXCEDIRB
25 . S DIR(0)=PXCEFILE_",.01OA"
26 . S DIR("A")=$P(PXCETEXT,"~",4)
27 . S:$P(PXCETEXT,"~",8)]"" DIR("?")=$P(PXCETEXT,"~",8)
28 . D ^DIR
29 I X="@" D G ENDEDIT
30 . N DIRUT
31 . I $P(PXCEAFTR(0),"^",1)="" D
32 .. W !,"There is no entry to delete."
33 .. D WAIT^PXCEHELP
34 . E D DEL^PXCEVFI2(PXCECAT)
35 I $D(DIRUT),$P(PXCEAFTR(0),"^",1)="" S PXCELOOP=1
36 I $D(DIRUT) S PXCEQUIT=1 Q
37 S (PXCEINP,PXD)=Y
38 S PXCEIN01=X
39 I $P(Y,"^",2)'=PXCEDIRB,$$DUP(PXCEINP) G EDIT01
40 ;--File new CPT code and retrieve IEN
41 I PXCECAT="CPT" D
42 . S PXMDCNT=$$CODM^ICPTCOD(+Y,"^TMP(""PXMODARR"",$J",PXCESOR,+^TMP("PXK",$J,"VST",1,0,"AFTER"))
43 . K ^TMP("PXMODARR",$J)
44 . I $P(PXCEAFTR(0),"^",1)'=""!(PXMDCNT'>0) Q
45 . N PXCEFIEN
46 . D NEWCODE^PXCECPT
47 . S ^TMP("PXK",$J,PXCECATS,1,"IEN")=PXCEFIEN
48 I PXCECAT="PRV",$P(PXCEAFTR(0),"^",1)>0,PXCEDIRB]"" S $P(PXCEAFTR(0),"^",6)=""
49 S $P(PXCEAFTR(0),"^",1)=$P(PXCEINP,"^")
50 K DIR,DA
51 ;
52 ;
53REST S PXCEEND=0
54 F PXCELINE=2:1 S PXCETEXT=$P($T(FORMAT+PXCELINE^@PXCECODE),";;",2) Q:PXCETEXT']"" D Q:PXCEEND
55 . I $P(PXCETEXT,"~",9)]"",$P(PXCETEXT,"~",3)'=80201 S PXCEKEY="" D Q:PXCEKEY'=1
56 .. S PXCENKEY=$L($P(PXCETEXT,"~",9))
57 .. F PXCEIKEY=1:1:PXCENKEY I PXCEKEYS[$E($P(PXCETEXT,"~",9),PXCEIKEY) S PXCEKEY=1 Q
58 . K DIR,DA,X,Y,C
59 . I $P(PXCETEXT,"~",7)]"" D
60 .. D @$P(PXCETEXT,"~",7)
61 . E D
62 .. I $P(PXCEAFTR($P(PXCETEXT,"~",1)),"^",$P(PXCETEXT,"~",2))'="" D
63 ... N DIERR,PXCEDILF,PXCEINT,PXCEEXT
64 ... S PXCEINT=$P(PXCEAFTR($P(PXCETEXT,"~",1)),"^",$P(PXCETEXT,"~",2))
65 ... S PXCEEXT=$$EXTERNAL^DILFD(PXCEFILE,$P(PXCETEXT,"~",3),"",PXCEINT,"PXCEDILF")
66 ... S DIR("B")=$S('$D(DIERR):PXCEEXT,1:PXCEINT)
67 .. S DIR(0)=PXCEFILE_","_$P(PXCETEXT,"~",3)_"A"
68 .. S DIR("A")=$P(PXCETEXT,"~",4)
69 .. S:$P(PXCETEXT,"~",8)]"" DIR("?")=$P(PXCETEXT,"~",8)
70 .. D ^DIR
71 .. K DIR,DA
72 .. I X="@" S Y="@"
73 .. E I $D(DTOUT)!$D(DUOUT) S PXCEEND=1 S:PXCECAT="SIT"!(PXCECAT="APPM")!(PXCECAT="HIST")!(PXCECAT="CPT") PXCEQUIT=1 Q
74 .. S $P(PXCEAFTR($P(PXCETEXT,"~",1)),"^",$P(PXCETEXT,"~",2))=$P(Y,"^")
75 . I ($P(PXCETEXT,"~",3)=1202!($P(PXCETEXT,"~",3)=1204)) D:+Y>0 PROVIDER^PXCEVFI4(+Y)
76 ;
77ENDEDIT ;
78 Q
79 ;
80DUP(PXCEINP) ; -- Check for dup entries.
81 Q:PXCECAT="SIT"!(PXCECAT="APPM")!(PXCECAT="HIST") 0
82 ;
83 N PXCEDUP,PXCEINDX,X,Y
84 S PXCEDUP=0
85 S PXCEINDX=""
86 F S PXCEINDX=$O(@(PXCEAUPN_"(""AD"",PXCEVIEN,PXCEINDX)")) Q:'PXCEINDX!PXCEDUP S:+@(PXCEAUPN_"(PXCEINDX,0)")=+PXCEINP&(PXCEINDX'=PXCEFIEN) PXCEDUP=1
87 I PXCEDUP D
88 . I PXCEDUP
89 . W !,$P(PXCEINP,"^",2)," is already a "_PXCECATT_" for this Encounter."
90 . I PXCECAT="POV" W !!,"Duplicate Diagnosis Not Allowed." Q ;PX/112
91 . I PXCECAT="CPT",$$GET1^DIQ(357.69,$P(PXCEINP,"^",2),.01)>0 D Q
92 . . W !,"No duplicate E&M codes allowed." ;PX/136
93 . I $P($T(FORMAT^@PXCECODE),"~",4) D
94 .. N DIR,DA
95 .. S DIR(0)="Y"
96 .. S DIR("A")="Do you want to add another "_$P(PXCEINP,"^",2)_""
97 .. S DIR("B")="NO"
98 .. D ^DIR
99 .. S PXCEDUP='+Y
100 Q PXCEDUP
101 ;
Note: See TracBrowser for help on using the repository browser.