Ignore:
Timestamp:
Dec 4, 2009, 12:11:15 AM (15 years ago)
Author:
George Lilly
Message:

revised back to 6/30/08 version

Location:
WorldVistAEHR/trunk/r/PCE_PATIENT_CARE_ENCOUNTER-AUTN-EFDP-PX-VSIT--PXRM
Files:
2 edited

Legend:

Unmodified
Added
Removed

  • WorldVistAEHR/trunk/r/PCE_PATIENT_CARE_ENCOUNTER-AUTN-EFDP-PX-VSIT--PXRM/PXBPCPT.m

    r613 r623  
    1 PXBPCPT ;ISL/JVS,ESW - PROMPT CPT ;3/18/05 12:55pm
    2         ;;1.0;PCE PATIENT CARE ENCOUNTER;**11,73,89,112,121,132,149,124,190**;Aug 12, 1996;Build 9
    3         ;
    4         ;
    5         ;
    6 CPT     ;--CPT CODE
    7         ;SELINE=LINE NUMBER OF SELECTED ITEM
    8         N TIMED,PXBUT,EDATA,DIC,LINE,XFLAG,SELINE
    9         N I,X,Y,Q,DOUBLEQQ,NF,BAD,OK,CPT,PXEDIT
    10         I '$D(^DISV(DUZ,"PXBCPT-1")) S ^DISV(DUZ,"PXBCPT-1")=" "
    11         I '$D(IOSC) D TERM^PXBCC
    12         S DOUBLEQQ=0,PXEDIT=""
    13         S TIMED="I '$T!(DATA[""^"")!(DATA="""")"
    14         S DIC("S")="I $$CPTSCREN^PXBUTL(Y,IDATE)"
    15 C       ;--SECOND ENTRY POINT
    16         W IOSC
    17         ;---DYNAMIC  HEADER-----------------
    18         I '$D(CYCL) D
    19         .I PXBCNT=0,DOUBLEQQ=0 D LOC^PXBCC(2,10) W IOUON,"...There are "_$G(PXBCNT)_" PROCEDURES associated with this encounter.",IOUOFF,IOELEOL
    20         .I PXBCNT=1,DOUBLEQQ=0 D LOC^PXBCC(2,10) W IOUON,"...There is "_$G(PXBCNT)_" PROCEDURE associated with this encounter.",IOUOFF,IOELEOL
    21         .I PXBCNT>1,DOUBLEQQ=0 D LOC^PXBCC(2,10) W IOUON,"...There are "_$G(PXBCNT)_" PROCEDURES associated with this encounter.",IOUOFF,IOELEOL
    22         ;
    23         D LOC^PXBCC(15,0)
    24         ;I PXBCNT>30
    25         ;W IOCUU,IOELEOL,
    26         W:PXTLNS>10 !,"Enter '+' for next page, '-' for last page." ;,IORC
    27         D WIN17^PXBCC(PXBCNT)
    28         I '$D(^TMP("PXK",$J,"CPT")) W !,"Enter PROCEDURE (CPT CODE): "
    29         I $D(^TMP("PXK",$J,"CPT")) W !,"Enter ",IOINHI,"NEXT",IOINLOW," PROCEDURE (CPT CODE): "
    30         W IOELEOL R DATA:DTIME S EDATA=DATA
    31 C1      ;----Third entry point
    32         X TIMED I  S PXBUT=1 S:DATA="^^" PXBEXIT=0 S:DATA="^^^" PXBRRR="" G CPTX
    33         I DATA?1.N1"E".NAP S DATA=" "_DATA
    34         I $L(DATA)>200 S (DATA,EDATA)=$E(DATA,1,199)
    35         I DATA?24.N S (DATA,EDATA)=$E(DATA,1,24)
    36         ; ----- Check & remove control character PX*190 -----
    37         S ZZDATA=""
    38         S ZDATA="" F J=1:1:$L(DATA) S ZDATA=$E(DATA,J)  D
    39         .I $A(ZDATA)>31,($A(ZDATA)'=127) S ZZDATA=ZZDATA_ZDATA
    40         I $L(ZZDATA)=0 W $C(7),"??" D HELP^PXBUTL0("CPTM") G C
    41         S (DATA,EDATA)=ZZDATA
    42         K ZZDATA,ZDATA,J
    43         ;
    44         D CASE^PXBUTL
    45         ;----SPACE BAR---
    46         I DATA=" ",$D(^DISV(DUZ,"PXBCPT-1")) S DATA=^DISV(DUZ,"PXBCPT-1") W DATA
    47         ;---------------
    48         I DATA["^P" G CPTX
    49         I DATA["^C" G CPTX
    50         ;
    51         I ((DATA="+")!(DATA="-")) D DISCPT4^PXBDCPT(DATA) G C
    52         ;
    53 M       ;--------If Multiple entries have been entered
    54         D ADDM^PXBPCPT1
    55         I $G(NF) G C1
    56         ;
    57 DEL     ;--------If Multiple deleting
    58         D DELM^PXBPCPT1
    59         I DATA["^C" G CPTX
    60         I $G(NF) G C1
    61         ;
    62         D MOD
    63         ;
    64 LI      ;--------If picked a line number display
    65         ;
    66         I (DATA>0)&(DATA<(PXBCNT+1))&($L(DATA)'>$L(PXBCNT)) D
    67         .S XFLAG=1
    68         .D DISCPT4^PXBDCPT(PXBSAM(DATA,"LINE"))
    69         .D REVCPT^PXBCC(DATA,1)
    70         .S SELINE=DATA
    71         .F I=1:1:$L(DATA) W IOCUB,IOECH
    72         .S CPTQUA=$P($G(PXBSAM(DATA)),"^",2)
    73         .S DATA=$P($G(PXBSAM(DATA)),"^",1)
    74         .;I $G(Q)'>1 W DATA
    75         I $D(XFLAG),XFLAG=1 S Y=DATA G FIN
    76         ;
    77         ;
    78         ;--------If CPT is already in the file
    79         I $D(PXBKY(DATA)) D  I +PXEDIT<0 S DATA="^C" G C1
    80         .D DISCPT4^PXBDCPT(PXBSAM($O(PXBKY(DATA,0)),"LINE"))
    81         .K Q
    82         .D TIMES^PXBUTL(DATA)
    83         .S PXEDIT=$$MULTI(DATA) Q:+PXEDIT<0
    84         .I Q=1 D
    85         ..S LINE=$O(PXBKY(DATA,0))
    86         ..S XFLAG=1
    87         ..Q:PXEDIT="A"
    88         ..D REVCPT^PXBCC(LINE,1)
    89         ..S CPTQUA=$P($G(PXBSAM(LINE)),"^",2)
    90         ..S SELINE=$O(Q(0))
    91         .I Q>1,PXEDIT="E" D
    92         ..N PXPG
    93         ..S NLINE=0
    94         ..S PXPG=+$G(^TMP("PXBDCPT",$J,"START"))+10
    95         ..F  S NLINE=$O(Q(NLINE)) Q:NLINE=""  Q:PXBSAM(NLINE,"LINE")>PXPG  D
    96         ...D REVCPT^PXBCC(NLINE,1)
    97         I '$G(Q) K SELINE
    98         I PXEDIT="E",$D(Q),Q>1 D  G:DATA="^C" C1 G LI
    99         .D WHICH^PXBPWCH S:DATA["^" DATA="^C"
    100         I $D(XFLAG),XFLAG=1 S Y=DATA G FIN
    101         ;
    102         ;--------Need to do a DIC lookup on data
    103         I DATA'="??" D  G:DATA="^C" C I DATA="?" G C
    104         .D:DATA="?" EN1^PXBHLP0("PXB","CPT",1,"",1)
    105         I DATA="??" D  G:UDATA="^C" C1 G FIN
    106         .S DOUBLEQQ=1
    107         .D EN1^PXBHLP0("PXB","CPT","",1,2)
    108         .I $L(DATA,"^")>1 D
    109         ..S DATA=+$P(DATA,"^",2)_$S($P(DATA,U,3)]"":"-"_$P(DATA,U,3),1:"")
    110         ..D MOD
    111         ..S Y=DATA
    112         .S:$G(UDATA)="" UDATA="^C"
    113         .S:UDATA="^C" (DATA,EDATA,Y)=UDATA
    114         ;
    115         ;--If a "?" is NOT entered during lookup
    116         S FROM="CPT",(VAL,Y)=$P($P($$DOUBLE1^PXBGCPT2(FROM),"^",2),"--",1)
    117         S (X,DATA,EDATA)=VAL,DIC=81,DIC(0)="MZ",DIC("S")="I $P($$CPT^ICPTCOD(Y,IDATE),U,7)" D ^DIC
    118         I Y<1 S DATA="^C" G C1
    119         ;
    120         ;--If Y is good and already in file...
    121         I $D(Y),$D(PXBKY(Y)) W IORC,IOCUU,IOEDEOP,! D
    122         .D DISCPT4^PXBDCPT($O(PXBKY($P(Y,"^",2),0)))
    123         .S LINE=$O(PXBKY($P(Y,"^",2),0)) D REVCPT^PXBCC(LINE,1)
    124         .S CPTQUA=$P($G(PXBSAM(LINE)),"^",2)
    125         ;
    126         ;
    127 FIN     ;--FINISH CPT
    128         I $G(SELINE) S $P(REQE,"^",1)=$P($G(PXBSAM(SELINE)),"^",3)
    129         I $P(REQE,"^",1)="" S $P(REQE,"^",1)="...No Provider Selected..."
    130         I $L(Y,"^")'>1 S X=Y,DIC=81,DIC(0)="ZM",DIC("S")="I $P($$CPT^ICPTCOD(Y,IDATE),U,7)" D ^DIC
    131         I Y<0 D HELP^PXBUTL0("CPTM") G C
    132         S OK=$$CPTOK^PXBUTL(+Y,IDATE) D  G:+OK=0 C
    133         .I +OK=0 W IOCUF,IOCUF,IORVON,"INACTIVE!--",IORVOFF D HELP1^PXBUTL1("CPTI") ;--HELP
    134         S CPT=Y(0)
    135         N PXINF S PXINF=$$CPT^ICPTCOD(+Y,IDATE),$P(CPT,U,2)=$P(PXINF,U,3)
    136         S ^DISV(DUZ,"PXBCPT-1")=$P(CPT,"^",1)
    137         I $D(PXBNCPT) S PXBNCPTF=1
    138         I $D(PXBKY(Y(0,0))),$G(SELINE) D
    139         .S $P(REQI,"^",8)=$O(PXBSKY(SELINE,0))
    140         .S PREDOC=$P(PXBSAM(SELINE),"^",3)
    141         .I $D(PXBPRV($P(REQE,"^",1),$P(CPT,"^",1))) D
    142         ..Q:$P(REQI,"^",8)]""
    143         ..S $P(REQI,"^",8)=$O(PXBPRV($P(REQE,"^",1),$P(CPT,"^",1),0))
    144         .I $D(PXBPRV($P(REQE,"^",1))) D
    145         ..S CPTQUA=$P(PXBSAM($O(PXBPRV($P(REQE,"^",1),$P(CPT,"^",1),$O(PXBPRV($P(REQE,"^",1),$P(CPT,"^",1),0)),0))),"^",2)
    146         I $D(PXBKY(Y(0,0))),'$G(SELINE) D
    147         .;S $P(REQI,"^",8)=$O(PXBSKY($O(PXBKY(Y(0,0),0)),0))
    148         .S PREDOC=$P(PXBSAM($O(PXBKY(Y(0,0),0))),"^",3)
    149         .I $D(PXBPRV($P(REQE,"^",1),$P(CPT,"^",1))) D
    150         ..S $P(REQI,"^",8)=$O(PXBPRV($P(REQE,"^",1),$P(CPT,"^",1),0))
    151         .I $D(PXBPRV($P(REQE,"^",1),$P(CPT,"^",1))) D
    152         ..S CPTQUA=$P(PXBSAM($O(PXBPRV($P(REQE,"^",1),$P(CPT,"^",1),$O(PXBPRV($P(REQE,"^",1),$P(CPT,"^",1),0)),0))),"^",2)
    153         S $P(REQI,"^",3)=+Y
    154         S $P(REQE,"^",3)=$P(CPT,"^",1)_"-- "_$P(CPT,"^",2)
    155         S PXBNCPT($P(CPT,"^",1))=$P(REQI,"^",8)
    156         S:$P(REQI,"^",8)]"" PXBNCPT($P(CPT,"^",1),$P(REQI,"^",8))=""
    157         ;PX124 adds to REQ*
    158 REST    I $P(REQI,U,8) D
    159         .N CTR,VAL,IEN
    160         .S IEN=$P(REQI,U,8)
    161         .S $P(REQI,U,13,19)=$P($G(^AUPNVCPT(IEN,0)),U,9,15)
    162         .S $P(REQI,U,12)=$P($G(^AUPNVCPT(IEN,0)),U,5)
    163         .F CTR=12:1:19 D
    164         ..S VAL=$P(REQI,U,CTR)
    165         ..S:VAL VAL=$$ICDDX^ICDCODE(VAL,IDATE),$P(REQE,U,CTR)=$P($G(VAL),U,2)_" --"_$P($G(VAL),U,4)
    166         .S VAL=$P($G(^AUPNVCPT(IEN,12)),U,2),$P(REQI,U,22)=VAL
    167         .S:VAL $P(REQE,U,22)=$P($G(^VA(200,VAL,0)),U,1)
    168         ;
    169 CPTX    ;--CPT Exit and cleanup
    170         I $P(REQE,"^",1)="" S $P(REQE,"^",1)="...No Provider Selected..."
    171         I $G(WHAT)="INTV",DATA="^" S PXBEXIT="^^"
    172         I $D(PXBRRR) S DATA="^"
    173         I $D(PREDOC) D
    174         .I PREDOC]""&($P(REQE,"^",1)'[PREDOC) W !,IOINHI,"--WARNING!",IOINLOW," Currently stored Provider of service:-",IOINHI,PREDOC,IOINLOW D
    175         ..I '$D(PXBPRV($P(REQE,"^",1),$P(CPT,"^",1))) S $P(REQI,"^",8)=""
    176         K PXBDPRV,PREDOC
    177         W IOEDEOP
    178         Q
    179 MOD     ;---Separate CPT modifiers from CPT codes in entry string, if entered
    180         I DATA?1.N1"-".NE D
    181         .S PXMODSTR=$P(DATA,"-",2)
    182         .S (DATA,EDATA)=$P(DATA,"-",1)
    183         Q
    184         ;
    185 MULTI(CPTCD)    ;--Prompt user to Edit existing CPT code or Add as new entry
    186         ;
    187         N DIR,DA,X,Y
    188         S DIR(0)="SB^E:EDIT;A:ADD"
    189         S DIR("A")="Do you wish to (E)dit or (A)dd"
    190         ;PX*2.0*132
    191         I (($E(CPTCD)?1N)&($D(^IBE(357.69,+CPTCD))))!(($E(CPTCD)?1A)&($D(^IBE(357.69,CPTCD)))) D
    192         .S DIR(0)="SB^E:EDIT",DIR("A")="You may only (E)dit this code, no duplicate E&M codes allowed."
    193         S DIR("A",1)="CPT "_CPTCD_" already on file for this Encounter"
    194         D ^DIR
    195         I Y']""!(Y="^") Q -1
    196         Q Y
     1PXBPCPT ;ISL/JVS,ESW - PROMPT CPT ;3/18/05 12:55pm
     2 ;;1.0;PCE PATIENT CARE ENCOUNTER;**11,73,89,112,121,132,149,124**;Aug 12, 1996
     3 ;
     4 ;
     5 ;
     6CPT ;--CPT CODE
     7 ;SELINE=LINE NUMBER OF SELECTED ITEM
     8 N TIMED,PXBUT,EDATA,DIC,LINE,XFLAG,SELINE
     9 N I,X,Y,Q,DOUBLEQQ,NF,BAD,OK,CPT,PXEDIT
     10 I '$D(^DISV(DUZ,"PXBCPT-1")) S ^DISV(DUZ,"PXBCPT-1")=" "
     11 I '$D(IOSC) D TERM^PXBCC
     12 S DOUBLEQQ=0,PXEDIT=""
     13 S TIMED="I '$T!(DATA[""^"")!(DATA="""")"
     14 S DIC("S")="I $$CPTSCREN^PXBUTL(Y,IDATE)"
     15C ;--SECOND ENTRY POINT
     16 W IOSC
     17 ;---DYNAMIC  HEADER-----------------
     18 I '$D(CYCL) D
     19 .I PXBCNT=0,DOUBLEQQ=0 D LOC^PXBCC(2,10) W IOUON,"...There are "_$G(PXBCNT)_" PROCEDURES associated with this encounter.",IOUOFF,IOELEOL
     20 .I PXBCNT=1,DOUBLEQQ=0 D LOC^PXBCC(2,10) W IOUON,"...There is "_$G(PXBCNT)_" PROCEDURE associated with this encounter.",IOUOFF,IOELEOL
     21 .I PXBCNT>1,DOUBLEQQ=0 D LOC^PXBCC(2,10) W IOUON,"...There are "_$G(PXBCNT)_" PROCEDURES associated with this encounter.",IOUOFF,IOELEOL
     22 ;
     23 D LOC^PXBCC(15,0)
     24 ;I PXBCNT>30
     25 ;W IOCUU,IOELEOL,
     26 W:PXTLNS>10 !,"Enter '+' for next page, '-' for last page." ;,IORC
     27 D WIN17^PXBCC(PXBCNT)
     28 I '$D(^TMP("PXK",$J,"CPT")) W !,"Enter PROCEDURE (CPT CODE): "
     29 I $D(^TMP("PXK",$J,"CPT")) W !,"Enter ",IOINHI,"NEXT",IOINLOW," PROCEDURE (CPT CODE): "
     30 W IOELEOL R DATA:DTIME S EDATA=DATA
     31C1 ;----Third entry point
     32 X TIMED I  S PXBUT=1 S:DATA="^^" PXBEXIT=0 S:DATA="^^^" PXBRRR="" G CPTX
     33 I DATA?1.N1"E".NAP S DATA=" "_DATA
     34 I $L(DATA)>200 S (DATA,EDATA)=$E(DATA,1,199)
     35 I DATA?24.N S (DATA,EDATA)=$E(DATA,1,24)
     36 D CASE^PXBUTL
     37 ;----SPACE BAR---
     38 I DATA=" ",$D(^DISV(DUZ,"PXBCPT-1")) S DATA=^DISV(DUZ,"PXBCPT-1") W DATA
     39 ;---------------
     40 I DATA["^P" G CPTX
     41 I DATA["^C" G CPTX
     42 ;
     43 I ((DATA="+")!(DATA="-")) D DISCPT4^PXBDCPT(DATA) G C
     44 ;
     45M ;--------If Multiple entries have been entered
     46 D ADDM^PXBPCPT1
     47 I $G(NF) G C1
     48 ;
     49DEL ;--------If Multiple deleting
     50 D DELM^PXBPCPT1
     51 I DATA["^C" G CPTX
     52 I $G(NF) G C1
     53 ;
     54 D MOD
     55 ;
     56LI ;--------If picked a line number display
     57 ;
     58 I (DATA>0)&(DATA<(PXBCNT+1))&($L(DATA)'>$L(PXBCNT)) D
     59 .S XFLAG=1
     60 .D DISCPT4^PXBDCPT(PXBSAM(DATA,"LINE"))
     61 .D REVCPT^PXBCC(DATA,1)
     62 .S SELINE=DATA
     63 .F I=1:1:$L(DATA) W IOCUB,IOECH
     64 .S CPTQUA=$P($G(PXBSAM(DATA)),"^",2)
     65 .S DATA=$P($G(PXBSAM(DATA)),"^",1)
     66 .;I $G(Q)'>1 W DATA
     67 I $D(XFLAG),XFLAG=1 S Y=DATA G FIN
     68 ;
     69 ;
     70 ;--------If CPT is already in the file
     71 I $D(PXBKY(DATA)) D  I +PXEDIT<0 S DATA="^C" G C1
     72 .D DISCPT4^PXBDCPT(PXBSAM($O(PXBKY(DATA,0)),"LINE"))
     73 .K Q
     74 .D TIMES^PXBUTL(DATA)
     75 .S PXEDIT=$$MULTI(DATA) Q:+PXEDIT<0
     76 .I Q=1 D
     77 ..S LINE=$O(PXBKY(DATA,0))
     78 ..S XFLAG=1
     79 ..Q:PXEDIT="A"
     80 ..D REVCPT^PXBCC(LINE,1)
     81 ..S CPTQUA=$P($G(PXBSAM(LINE)),"^",2)
     82 ..S SELINE=$O(Q(0))
     83 .I Q>1,PXEDIT="E" D
     84 ..N PXPG
     85 ..S NLINE=0
     86 ..S PXPG=+$G(^TMP("PXBDCPT",$J,"START"))+10
     87 ..F  S NLINE=$O(Q(NLINE)) Q:NLINE=""  Q:PXBSAM(NLINE,"LINE")>PXPG  D
     88 ...D REVCPT^PXBCC(NLINE,1)
     89 I '$G(Q) K SELINE
     90 I PXEDIT="E",$D(Q),Q>1 D  G:DATA="^C" C1 G LI
     91 .D WHICH^PXBPWCH S:DATA["^" DATA="^C"
     92 I $D(XFLAG),XFLAG=1 S Y=DATA G FIN
     93 ;
     94 ;--------Need to do a DIC lookup on data
     95 I DATA'="??" D  G:DATA="^C" C I DATA="?" G C
     96 .D:DATA="?" EN1^PXBHLP0("PXB","CPT",1,"",1)
     97 I DATA="??" D  G:UDATA="^C" C1 G FIN
     98 .S DOUBLEQQ=1
     99 .D EN1^PXBHLP0("PXB","CPT","",1,2)
     100 .I $L(DATA,"^")>1 D
     101 ..S DATA=+$P(DATA,"^",2)_$S($P(DATA,U,3)]"":"-"_$P(DATA,U,3),1:"")
     102 ..D MOD
     103 ..S Y=DATA
     104 .S:$G(UDATA)="" UDATA="^C"
     105 .S:UDATA="^C" (DATA,EDATA,Y)=UDATA
     106 ;
     107 ;--If a "?" is NOT entered during lookup
     108 S FROM="CPT",(VAL,Y)=$P($P($$DOUBLE1^PXBGCPT2(FROM),"^",2),"--",1)
     109 S (X,DATA,EDATA)=VAL,DIC=81,DIC(0)="MZ",DIC("S")="I $P($$CPT^ICPTCOD(Y,IDATE),U,7)" D ^DIC
     110 I Y<1 S DATA="^C" G C1
     111 ;
     112 ;--If Y is good and already in file...
     113 I $D(Y),$D(PXBKY(Y)) W IORC,IOCUU,IOEDEOP,! D
     114 .D DISCPT4^PXBDCPT($O(PXBKY($P(Y,"^",2),0)))
     115 .S LINE=$O(PXBKY($P(Y,"^",2),0)) D REVCPT^PXBCC(LINE,1)
     116 .S CPTQUA=$P($G(PXBSAM(LINE)),"^",2)
     117 ;
     118 ;
     119FIN ;--FINISH CPT
     120 I $G(SELINE) S $P(REQE,"^",1)=$P($G(PXBSAM(SELINE)),"^",3)
     121 I $P(REQE,"^",1)="" S $P(REQE,"^",1)="...No Provider Selected..."
     122 I $L(Y,"^")'>1 S X=Y,DIC=81,DIC(0)="ZM",DIC("S")="I $P($$CPT^ICPTCOD(Y,IDATE),U,7)" D ^DIC
     123 I Y<0 D HELP^PXBUTL0("CPTM") G C
     124 S OK=$$CPTOK^PXBUTL(+Y,IDATE) D  G:+OK=0 C
     125 .I +OK=0 W IOCUF,IOCUF,IORVON,"INACTIVE!--",IORVOFF D HELP1^PXBUTL1("CPTI") ;--HELP
     126 S CPT=Y(0)
     127 N PXINF S PXINF=$$CPT^ICPTCOD(+Y,IDATE),$P(CPT,U,2)=$P(PXINF,U,3)
     128 S ^DISV(DUZ,"PXBCPT-1")=$P(CPT,"^",1)
     129 I $D(PXBNCPT) S PXBNCPTF=1
     130 I $D(PXBKY(Y(0,0))),$G(SELINE) D
     131 .S $P(REQI,"^",8)=$O(PXBSKY(SELINE,0))
     132 .S PREDOC=$P(PXBSAM(SELINE),"^",3)
     133 .I $D(PXBPRV($P(REQE,"^",1),$P(CPT,"^",1))) D
     134 ..Q:$P(REQI,"^",8)]""
     135 ..S $P(REQI,"^",8)=$O(PXBPRV($P(REQE,"^",1),$P(CPT,"^",1),0))
     136 .I $D(PXBPRV($P(REQE,"^",1))) D
     137 ..S CPTQUA=$P(PXBSAM($O(PXBPRV($P(REQE,"^",1),$P(CPT,"^",1),$O(PXBPRV($P(REQE,"^",1),$P(CPT,"^",1),0)),0))),"^",2)
     138 I $D(PXBKY(Y(0,0))),'$G(SELINE) D
     139 .;S $P(REQI,"^",8)=$O(PXBSKY($O(PXBKY(Y(0,0),0)),0))
     140 .S PREDOC=$P(PXBSAM($O(PXBKY(Y(0,0),0))),"^",3)
     141 .I $D(PXBPRV($P(REQE,"^",1),$P(CPT,"^",1))) D
     142 ..S $P(REQI,"^",8)=$O(PXBPRV($P(REQE,"^",1),$P(CPT,"^",1),0))
     143 .I $D(PXBPRV($P(REQE,"^",1),$P(CPT,"^",1))) D
     144 ..S CPTQUA=$P(PXBSAM($O(PXBPRV($P(REQE,"^",1),$P(CPT,"^",1),$O(PXBPRV($P(REQE,"^",1),$P(CPT,"^",1),0)),0))),"^",2)
     145 S $P(REQI,"^",3)=+Y
     146 S $P(REQE,"^",3)=$P(CPT,"^",1)_"-- "_$P(CPT,"^",2)
     147 S PXBNCPT($P(CPT,"^",1))=$P(REQI,"^",8)
     148 S:$P(REQI,"^",8)]"" PXBNCPT($P(CPT,"^",1),$P(REQI,"^",8))=""
     149 ;PX124 adds to REQ*
     150REST I $P(REQI,U,8) D
     151 .N CTR,VAL,IEN
     152 .S IEN=$P(REQI,U,8)
     153 .S $P(REQI,U,13,19)=$P($G(^AUPNVCPT(IEN,0)),U,9,15)
     154 .S $P(REQI,U,12)=$P($G(^AUPNVCPT(IEN,0)),U,5)
     155 .F CTR=12:1:19 D
     156 ..S VAL=$P(REQI,U,CTR)
     157 ..S:VAL VAL=$$ICDDX^ICDCODE(VAL,IDATE),$P(REQE,U,CTR)=$P($G(VAL),U,2)_" --"_$P($G(VAL),U,4)
     158 .S VAL=$P($G(^AUPNVCPT(IEN,12)),U,2),$P(REQI,U,22)=VAL
     159 .S:VAL $P(REQE,U,22)=$P($G(^VA(200,VAL,0)),U,1)
     160 ;
     161CPTX ;--CPT Exit and cleanup
     162 I $P(REQE,"^",1)="" S $P(REQE,"^",1)="...No Provider Selected..."
     163 I $G(WHAT)="INTV",DATA="^" S PXBEXIT="^^"
     164 I $D(PXBRRR) S DATA="^"
     165 I $D(PREDOC) D
     166 .I PREDOC]""&($P(REQE,"^",1)'[PREDOC) W !,IOINHI,"--WARNING!",IOINLOW," Currently stored Provider of service:-",IOINHI,PREDOC,IOINLOW D
     167 ..I '$D(PXBPRV($P(REQE,"^",1),$P(CPT,"^",1))) S $P(REQI,"^",8)=""
     168 K PXBDPRV,PREDOC
     169 W IOEDEOP
     170 Q
     171MOD ;---Separate CPT modifiers from CPT codes in entry string, if entered
     172 I DATA?1.N1"-".NE D
     173 .S PXMODSTR=$P(DATA,"-",2)
     174 .S (DATA,EDATA)=$P(DATA,"-",1)
     175 Q
     176 ;
     177MULTI(CPTCD) ;--Prompt user to Edit existing CPT code or Add as new entry
     178 ;
     179 N DIR,DA,X,Y
     180 S DIR(0)="SB^E:EDIT;A:ADD"
     181 S DIR("A")="Do you wish to (E)dit or (A)dd"
     182 ;PX*2.0*132
     183 I (($E(CPTCD)?1N)&($D(^IBE(357.69,+CPTCD))))!(($E(CPTCD)?1A)&($D(^IBE(357.69,CPTCD)))) D
     184 .S DIR(0)="SB^E:EDIT",DIR("A")="You may only (E)dit this code, no duplicate E&M codes allowed."
     185 S DIR("A",1)="CPT "_CPTCD_" already on file for this Encounter"
     186 D ^DIR
     187 I Y']""!(Y="^") Q -1
     188 Q Y

  • 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         ;
     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 TracChangeset for help on using the changeset viewer.