PXCEVFI1 ;ISL/dee,esw - Routine to edit a visit or v-file entry ; 12/17/02 8:23am
;;1.0;PCE PATIENT CARE ENCOUNTER;**23,73,112**;Aug 12, 1996
Q
;
EDIT ; -- edit the V-File stored in "AFTER"
N DIR,DA,X,Y,C,PXCEINP,PXCEIN01,PXCEEND
N PXCELINE,PXCETEXT,PXCEDIRB,PXCEMOD
N PXCEKEY,PXCEIKEY,PXCENKEY,PXMDCNT
W !
G:PXCECAT="VST"!(PXCECAT="APPM")!(PXCECAT="CSTP") REST
;
EDIT01 ;
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=Y
S PXCEIN01=X
I X'=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
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") 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",$D(^IBE(357.69,+$P(PXCEINP,U,2))) W !,"No Duplicate E&M Codes Are Allowed." Q ;DBIA #: 1906
. 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
;
PXCEVFI1 ;ISL/dee,esw - Routine to edit a visit or v-file entry ; 12/17/02 8:23am
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**23,73,112**;Aug 12, 1996
+2 QUIT
+3 ;
EDIT ; -- edit the V-File stored in "AFTER"
+1 NEW DIR,DA,X,Y,C,PXCEINP,PXCEIN01,PXCEEND
+2 NEW PXCELINE,PXCETEXT,PXCEDIRB,PXCEMOD
+3 NEW PXCEKEY,PXCEIKEY,PXCENKEY,PXMDCNT
+4 WRITE !
+5 IF PXCECAT="VST"!(PXCECAT="APPM")!(PXCECAT="CSTP")
GOTO REST
+6 ;
EDIT01 ;
+1 SET PXCETEXT=$PIECE($TEXT(FORMAT+1^@PXCECODE),";;",2)
+2 KILL DIR,DA,X,Y,C,PXCEDIRB
+3 IF $PIECE(PXCEAFTR(0),"^",1)
Begin DoDot:1
+4 NEW DIEER,PXCEDILF,PXCEEXT
+5 SET PXCEEXT=$$EXTERNAL^DILFD(PXCEFILE,.01,"",$PIECE(PXCEAFTR(0),"^",1),"PXCEDILF")
+6 SET PXCEDIRB=$SELECT('$DATA(DIERR):PXCEEXT,1:$PIECE(PXCEAFTR(0),"^",1))
End DoDot:1
+7 IF '$TEST
SET PXCEDIRB=""
+8 IF $PIECE(PXCETEXT,"~",7)]""
Begin DoDot:1
+9 DO @$PIECE(PXCETEXT,"~",7)
End DoDot:1
+10 IF '$TEST
Begin DoDot:1
+11 IF PXCEDIRB'=""
SET DIR("B")=PXCEDIRB
+12 SET DIR(0)=PXCEFILE_",.01OA"
+13 SET DIR("A")=$PIECE(PXCETEXT,"~",4)
+14 IF $PIECE(PXCETEXT,"~",8)]""
SET DIR("?")=$PIECE(PXCETEXT,"~",8)
+15 DO ^DIR
End DoDot:1
+16 IF X="@"
Begin DoDot:1
+17 NEW DIRUT
+18 IF $PIECE(PXCEAFTR(0),"^",1)=""
Begin DoDot:2
+19 WRITE !,"There is no entry to delete."
+20 DO WAIT^PXCEHELP
End DoDot:2
+21 IF '$TEST
DO DEL^PXCEVFI2(PXCECAT)
End DoDot:1
GOTO ENDEDIT
+22 IF $DATA(DIRUT)
IF $PIECE(PXCEAFTR(0),"^",1)=""
SET PXCELOOP=1
+23 IF $DATA(DIRUT)
SET PXCEQUIT=1
QUIT
+24 SET PXCEINP=Y
+25 SET PXCEIN01=X
+26 IF X'=PXCEDIRB
IF $$DUP(PXCEINP)
GOTO EDIT01
+27 ;--File new CPT code and retrieve IEN
+28 IF PXCECAT="CPT"
Begin DoDot:1
+29 SET PXMDCNT=$$CODM^ICPTCOD(+Y,"^TMP(""PXMODARR"",$J",PXCESOR,+^TMP("PXK",$JOB,"VST",1,0,"AFTER"))
+30 KILL ^TMP("PXMODARR",$JOB)
+31 IF $PIECE(PXCEAFTR(0),"^",1)'=""!(PXMDCNT'>0)
QUIT
+32 NEW PXCEFIEN
+33 DO NEWCODE^PXCECPT
+34 SET ^TMP("PXK",$JOB,PXCECATS,1,"IEN")=PXCEFIEN
End DoDot:1
+35 SET $PIECE(PXCEAFTR(0),"^",1)=$PIECE(PXCEINP,"^")
+36 KILL DIR,DA
+37 ;
+38 ;
REST SET PXCEEND=0
+1 FOR PXCELINE=2:1
SET PXCETEXT=$PIECE($TEXT(FORMAT+PXCELINE^@PXCECODE),";;",2)
IF PXCETEXT']""
QUIT
Begin DoDot:1
+2 IF $PIECE(PXCETEXT,"~",9)]""
IF $PIECE(PXCETEXT,"~",3)'=80201
SET PXCEKEY=""
Begin DoDot:2
+3 SET PXCENKEY=$LENGTH($PIECE(PXCETEXT,"~",9))
+4 FOR PXCEIKEY=1:1:PXCENKEY
IF PXCEKEYS[$EXTRACT($PIECE(PXCETEXT,"~",9),PXCEIKEY)
SET PXCEKEY=1
QUIT
End DoDot:2
IF PXCEKEY'=1
QUIT
+5 KILL DIR,DA,X,Y,C
+6 IF $PIECE(PXCETEXT,"~",7)]""
Begin DoDot:2
+7 DO @$PIECE(PXCETEXT,"~",7)
End DoDot:2
+8 IF '$TEST
Begin DoDot:2
+9 IF $PIECE(PXCEAFTR($PIECE(PXCETEXT,"~",1)),"^",$PIECE(PXCETEXT,"~",2))'=""
Begin DoDot:3
+10 NEW DIERR,PXCEDILF,PXCEINT,PXCEEXT
+11 SET PXCEINT=$PIECE(PXCEAFTR($PIECE(PXCETEXT,"~",1)),"^",$PIECE(PXCETEXT,"~",2))
+12 SET PXCEEXT=$$EXTERNAL^DILFD(PXCEFILE,$PIECE(PXCETEXT,"~",3),"",PXCEINT,"PXCEDILF")
+13 SET DIR("B")=$SELECT('$DATA(DIERR):PXCEEXT,1:PXCEINT)
End DoDot:3
+14 SET DIR(0)=PXCEFILE_","_$PIECE(PXCETEXT,"~",3)_"A"
+15 SET DIR("A")=$PIECE(PXCETEXT,"~",4)
+16 IF $PIECE(PXCETEXT,"~",8)]""
SET DIR("?")=$PIECE(PXCETEXT,"~",8)
+17 DO ^DIR
+18 KILL DIR,DA
+19 IF X="@"
SET Y="@"
+20 IF '$TEST
IF $DATA(DTOUT)!$DATA(DUOUT)
SET PXCEEND=1
IF PXCECAT="SIT"!(PXCECAT="APPM")!(PXCECAT="HIST")
SET PXCEQUIT=1
QUIT
+21 SET $PIECE(PXCEAFTR($PIECE(PXCETEXT,"~",1)),"^",$PIECE(PXCETEXT,"~",2))=$PIECE(Y,"^")
End DoDot:2
+22 IF ($PIECE(PXCETEXT,"~",3)=1202!($PIECE(PXCETEXT,"~",3)=1204))
IF +Y>0
DO PROVIDER^PXCEVFI4(+Y)
End DoDot:1
IF PXCEEND
QUIT
+23 ;
ENDEDIT ;
+1 QUIT
+2 ;
DUP(PXCEINP) ; -- Check for dup entries.
+1 IF PXCECAT="SIT"!(PXCECAT="APPM")!(PXCECAT="HIST")
QUIT 0
+2 ;
+3 NEW PXCEDUP,PXCEINDX,X,Y
+4 SET PXCEDUP=0
+5 SET PXCEINDX=""
+6 FOR
SET PXCEINDX=$ORDER(@(PXCEAUPN_"(""AD"",PXCEVIEN,PXCEINDX)"))
IF 'PXCEINDX!PXCEDUP
QUIT
IF +@(PXCEAUPN_"(PXCEINDX,0)")=+PXCEINP&(PXCEINDX'=PXCEFIEN)
SET PXCEDUP=1
+7 IF PXCEDUP
Begin DoDot:1
+8 IF PXCEDUP
+9 WRITE !,$PIECE(PXCEINP,"^",2)," is already a "_PXCECATT_" for this Encounter."
+10 ;PX/112
IF PXCECAT="POV"
WRITE !!,"Duplicate Diagnosis Not Allowed."
QUIT
+11 ;DBIA #: 1906
IF PXCECAT="CPT"
IF $DATA(^IBE(357.69,+$PIECE(PXCEINP,U,2)))
WRITE !,"No Duplicate E&M Codes Are Allowed."
QUIT
+12 IF $PIECE($TEXT(FORMAT^@PXCECODE),"~",4)
Begin DoDot:2
+13 NEW DIR,DA
+14 SET DIR(0)="Y"
+15 SET DIR("A")="Do you want to add another "_$PIECE(PXCEINP,"^",2)_""
+16 SET DIR("B")="NO"
+17 DO ^DIR
+18 SET PXCEDUP='+Y
End DoDot:2
End DoDot:1
+19 QUIT PXCEDUP
+20 ;
