Changeset 623 for WorldVistAEHR/trunk/r/PCE_PATIENT_CARE_ENCOUNTER-AUTN-EFDP-PX-VSIT--PXRM/PXCEVFI1.m
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/PCE_PATIENT_CARE_ENCOUNTER-AUTN-EFDP-PX-VSIT--PXRM/PXCEVFI1.m
r613 r623 1 PXCEVFI1 ;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,185**;Aug 12, 1996;Build 12 3 Q 4 ; 5 EDIT ; -- 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 ; 12 EDIT01 ; 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 ;following code added per PX*185 52 I $D(XQORNOD(0)) I $P(XQORNOD(0),U,4)="HF" D 53 .N HFIEN,NODE 54 .S HFIEN=$P(PXCEINP,U),NODE=$G(^AUTTHF(HFIEN,0)) 55 .Q:'$D(NODE) 56 .I $P(NODE,U,8)'="Y" W !!,"WARNING: This Health Factor is currently not set to",!?10,"display on a Health Summary report.",!! 57 .K HFIEN,NODE 58 .Q 59 ; 60 ; 61 REST S PXCEEND=0 62 F PXCELINE=2:1 S PXCETEXT=$P($T(FORMAT+PXCELINE^@PXCECODE),";;",2) Q:PXCETEXT']"" D Q:PXCEEND 63 . I $P(PXCETEXT,"~",9)]"",$P(PXCETEXT,"~",3)'=80201 S PXCEKEY="" D Q:PXCEKEY'=1 64 .. S PXCENKEY=$L($P(PXCETEXT,"~",9)) 65 .. F PXCEIKEY=1:1:PXCENKEY I PXCEKEYS[$E($P(PXCETEXT,"~",9),PXCEIKEY) S PXCEKEY=1 Q 66 . K DIR,DA,X,Y,C 67 . I $P(PXCETEXT,"~",7)]"" D 68 .. D @$P(PXCETEXT,"~",7) 69 . E D 70 .. I $P(PXCEAFTR($P(PXCETEXT,"~",1)),"^",$P(PXCETEXT,"~",2))'="" D 71 ... N DIERR,PXCEDILF,PXCEINT,PXCEEXT 72 ... S PXCEINT=$P(PXCEAFTR($P(PXCETEXT,"~",1)),"^",$P(PXCETEXT,"~",2)) 73 ... S PXCEEXT=$$EXTERNAL^DILFD(PXCEFILE,$P(PXCETEXT,"~",3),"",PXCEINT,"PXCEDILF") 74 ... S DIR("B")=$S('$D(DIERR):PXCEEXT,1:PXCEINT) 75 .. S DIR(0)=PXCEFILE_","_$P(PXCETEXT,"~",3)_"A" 76 .. S DIR("A")=$P(PXCETEXT,"~",4) 77 .. S:$P(PXCETEXT,"~",8)]"" DIR("?")=$P(PXCETEXT,"~",8) 78 .. D ^DIR 79 .. K DIR,DA 80 .. I X="@" S Y="@" 81 .. E I $D(DTOUT)!$D(DUOUT) S PXCEEND=1 S:PXCECAT="SIT"!(PXCECAT="APPM")!(PXCECAT="HIST")!(PXCECAT="CPT") PXCEQUIT=1 Q 82 .. S $P(PXCEAFTR($P(PXCETEXT,"~",1)),"^",$P(PXCETEXT,"~",2))=$P(Y,"^") 83 . I ($P(PXCETEXT,"~",3)=1202!($P(PXCETEXT,"~",3)=1204)) D:+Y>0 PROVIDER^PXCEVFI4(+Y) 84 ; 85 ENDEDIT ; 86 Q 87 ; 88 DUP(PXCEINP) ; -- Check for dup entries. 89 Q:PXCECAT="SIT"!(PXCECAT="APPM")!(PXCECAT="HIST") 0 90 ; 91 N PXCEDUP,PXCEINDX,X,Y 92 S PXCEDUP=0 93 S PXCEINDX="" 94 F S PXCEINDX=$O(@(PXCEAUPN_"(""AD"",PXCEVIEN,PXCEINDX)")) Q:'PXCEINDX!PXCEDUP S:+@(PXCEAUPN_"(PXCEINDX,0)")=+PXCEINP&(PXCEINDX'=PXCEFIEN) PXCEDUP=1 95 I PXCEDUP D 96 . I PXCEDUP 97 . W !,$P(PXCEINP,"^",2)," is already a "_PXCECATT_" for this Encounter." 98 . I PXCECAT="POV" W !!,"Duplicate Diagnosis Not Allowed." Q ;PX/112 99 . I PXCECAT="CPT",$$GET1^DIQ(357.69,$P(PXCEINP,"^",2),.01)>0 D Q 100 . . W !,"No duplicate E&M codes allowed." ;PX/136 101 . I $P($T(FORMAT^@PXCECODE),"~",4) D 102 .. N DIR,DA 103 .. S DIR(0)="Y" 104 .. S DIR("A")="Do you want to add another "_$P(PXCEINP,"^",2)_"" 105 .. S DIR("B")="NO" 106 .. D ^DIR 107 .. S PXCEDUP='+Y 108 Q PXCEDUP 109 ; 1 PXCEVFI1 ;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 ; 5 EDIT ; -- 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 ; 12 EDIT01 ; 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 ; 53 REST 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 ; 77 ENDEDIT ; 78 Q 79 ; 80 DUP(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 TracChangeset
for help on using the changeset viewer.
