- 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 ;
