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

PXCEVFI1 ;ISL/dee,esw - Routine to edit a visit or v-file entry ;8/3/04 10:32am
 ;;1.0;PCE PATIENT CARE ENCOUNTER;**23,73,112,136,143,124,184**;Aug 12, 1996;Build 30
 Q
 ;
EDIT ; -- edit the V-File stored in "AFTER"
 N DIR,DA,X,Y,C,PXCEINP,PXCEIN01,PXCEEND,PXD
 N PXCELINE,PXCETEXT,PXCEDIRB,PXCEMOD
 N PXCEKEY,PXCEIKEY,PXCENKEY,PXMDCNT
 W !
 G:PXCECAT="VST"!(PXCECAT="APPM")!(PXCECAT="CSTP") REST
 ;
EDIT01 ;
 I PXCECAT="CPT"!(PXCECAT="POV")!(PXCECAT="SK")!(PXCECAT="IMM") D SC^PXCEVFI2($P(^AUPNVSIT(PXCEVIEN,0),U,5))
 S PXCETEXT=$P($T(FORMAT+1^@PXCECODE),";;",2)
 K DIR,DA,X,Y,C,PXCEDIRB
 I $P(PXCEAFTR(0),"^",1) D
 . N DIEER,PXCEDILF,PXCEEXT
 . S PXCEEXT=$$EXTERNAL^DILFD(PXCEFILE,.01,"",$P(PXCEAFTR(0),"^",1),"PXCEDILF")
 . S PXCEDIRB=$S('$D(DIERR):PXCEEXT,1:$P(PXCEAFTR(0),"^",1))
 E  S PXCEDIRB=""
 I $P(PXCETEXT,"~",7)]"" D
 . D @$P(PXCETEXT,"~",7)
 E  D
 . I PXCEDIRB'="" S DIR("B")=PXCEDIRB
 . S DIR(0)=PXCEFILE_",.01OA"
 . S DIR("A")=$P(PXCETEXT,"~",4)
 . S:$P(PXCETEXT,"~",8)]"" DIR("?")=$P(PXCETEXT,"~",8)
 . D ^DIR
 I X="@" D  G ENDEDIT
 . N DIRUT
 . I $P(PXCEAFTR(0),"^",1)="" D
 .. W !,"There is no entry to delete."
 .. D WAIT^PXCEHELP
 . E  D DEL^PXCEVFI2(PXCECAT)
 I $D(DIRUT),$P(PXCEAFTR(0),"^",1)="" S PXCELOOP=1
 I $D(DIRUT) S PXCEQUIT=1 Q
 S (PXCEINP,PXD)=Y
 S PXCEIN01=X
 I $P(Y,"^",2)'=PXCEDIRB,$$DUP(PXCEINP) G EDIT01
 ;--File new CPT code and retrieve IEN
 I PXCECAT="CPT" D
 . S PXMDCNT=$$CODM^ICPTCOD(+Y,"^TMP(""PXMODARR"",$J",PXCESOR,+^TMP("PXK",$J,"VST",1,0,"AFTER"))
 . K ^TMP("PXMODARR",$J)
 . I $P(PXCEAFTR(0),"^",1)'=""!(PXMDCNT'>0) Q
 . N PXCEFIEN
 . D NEWCODE^PXCECPT
 . S ^TMP("PXK",$J,PXCECATS,1,"IEN")=PXCEFIEN
 I PXCECAT="PRV",$P(PXCEAFTR(0),"^",1)>0,PXCEDIRB]"" S $P(PXCEAFTR(0),"^",6)=""
 S $P(PXCEAFTR(0),"^",1)=$P(PXCEINP,"^")
 K DIR,DA
 ;
 ;
REST S PXCEEND=0
 F PXCELINE=2:1 S PXCETEXT=$P($T(FORMAT+PXCELINE^@PXCECODE),";;",2) Q:PXCETEXT']""  D  Q:PXCEEND
 . I $P(PXCETEXT,"~",9)]"",$P(PXCETEXT,"~",3)'=80201 S PXCEKEY="" D  Q:PXCEKEY'=1
 .. S PXCENKEY=$L($P(PXCETEXT,"~",9))
 .. F PXCEIKEY=1:1:PXCENKEY I PXCEKEYS[$E($P(PXCETEXT,"~",9),PXCEIKEY) S PXCEKEY=1 Q
 . K DIR,DA,X,Y,C
 . I $P(PXCETEXT,"~",7)]"" D
 .. D @$P(PXCETEXT,"~",7)
 . E  D
 .. I $P(PXCEAFTR($P(PXCETEXT,"~",1)),"^",$P(PXCETEXT,"~",2))'="" D
 ... N DIERR,PXCEDILF,PXCEINT,PXCEEXT
 ... S PXCEINT=$P(PXCEAFTR($P(PXCETEXT,"~",1)),"^",$P(PXCETEXT,"~",2))
 ... S PXCEEXT=$$EXTERNAL^DILFD(PXCEFILE,$P(PXCETEXT,"~",3),"",PXCEINT,"PXCEDILF")
 ... S DIR("B")=$S('$D(DIERR):PXCEEXT,1:PXCEINT)
 .. S DIR(0)=PXCEFILE_","_$P(PXCETEXT,"~",3)_"A"
 .. S DIR("A")=$P(PXCETEXT,"~",4)
 .. S:$P(PXCETEXT,"~",8)]"" DIR("?")=$P(PXCETEXT,"~",8)
 .. D ^DIR
 .. K DIR,DA
 .. I X="@" S Y="@"
 .. E  I $D(DTOUT)!$D(DUOUT) S PXCEEND=1 S:PXCECAT="SIT"!(PXCECAT="APPM")!(PXCECAT="HIST")!(PXCECAT="CPT") PXCEQUIT=1 Q
 .. S $P(PXCEAFTR($P(PXCETEXT,"~",1)),"^",$P(PXCETEXT,"~",2))=$P(Y,"^")
 . I ($P(PXCETEXT,"~",3)=1202!($P(PXCETEXT,"~",3)=1204)) D:+Y>0 PROVIDER^PXCEVFI4(+Y)
 ;
ENDEDIT ;
 Q
 ;
DUP(PXCEINP) ; -- Check for dup entries.
 Q:PXCECAT="SIT"!(PXCECAT="APPM")!(PXCECAT="HIST") 0
 ;
 N PXCEDUP,PXCEINDX,X,Y
 S PXCEDUP=0
 S PXCEINDX=""
 F  S PXCEINDX=$O(@(PXCEAUPN_"(""AD"",PXCEVIEN,PXCEINDX)")) Q:'PXCEINDX!PXCEDUP  S:+@(PXCEAUPN_"(PXCEINDX,0)")=+PXCEINP&(PXCEINDX'=PXCEFIEN) PXCEDUP=1
 I PXCEDUP D
 . I PXCEDUP
 . W !,$P(PXCEINP,"^",2)," is already a "_PXCECATT_" for this Encounter."
 . I PXCECAT="POV" W !!,"Duplicate Diagnosis Not Allowed." Q  ;PX/112
 . I PXCECAT="CPT",$$GET1^DIQ(357.69,$P(PXCEINP,"^",2),.01)>0 D  Q
 . . W !,"No duplicate E&M codes allowed."   ;PX/136
 . I $P($T(FORMAT^@PXCECODE),"~",4) D
 .. N DIR,DA
 .. S DIR(0)="Y"
 .. S DIR("A")="Do you want to add another "_$P(PXCEINP,"^",2)_""
 .. S DIR("B")="NO"
 .. D ^DIR
 .. S PXCEDUP='+Y
 Q PXCEDUP
 ;