source: WorldVistAEHR/trunk/r/PCE_PATIENT_CARE_ENCOUNTER-AUTN-EFDP-PX-VSIT--PXRM/PXBMCPT2.m@ 724

Last change on this file since 724 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.8 KB
Line 
1PXBMCPT2 ;ISL/JVS,ESW - MAIN ROUTINE CPT CODES ;3/22/05 9:22am
2 ;;1.0;PCE PATIENT CARE ENCOUNTER;**11,73,88,89,108,124**;Aug 12, 1996
3 ;
4 W !,"This is not the entry into this routine" Q
5 ;
6 ; VARABLE LIST
7 ;
8 ;
9CPT(PXBVST) ;---Real entry point
10 Q:'$D(^AUPNVSIT(PXBVST))
11 S TEST=1
12 ; PXBVST = Appiontment-Encounter Visit IEN
13 ; PXBDPRV = Default Provider for clinic appointment IEN
14 ;--Set up
15 N PXBSKY,PXBKY,PXBSAM,PRVDR,FPRI ;108
16 N PXBCNT,I,J,IDATE,PRIP,PRIPOV,PRISEC,QUA,VISIT,PRI,POV,PRV,PXBENT,SAVE
17 N PXBUT,FPRI,ENTRY,PXBSAVE,NAME,VAR,DOUBLEQQ,CPTQUA,PXBPRV,ERROR
18 N REQI,REQE,DEL,COM,FROM,NOREV,PX124,PXCEAFTR,PXCEVIEN
19 N DATA,PROMPT,FIRSTCPT,KFIRST,FROM,IDATE,%,CYCL,PXBDXPRI
20 N PXBNCPT,PXBNPRV,PXBNPOV,FIRST,PXBWIN,CLINIC
21 N PXBPMT,LEAVE,PATIENT,PXMODSTR,PXMDCNT,PXNEWIEN,PXMREQ,PXTLNS
22 S (REQE,REQI)=""
23 S CLINIC=$P(^AUPNVSIT(PXBVST,0),"^",22),PROMPT="CPT"
24 ;--KILL OF THE TMP GLOGALS IN ALL PROMPTS
25 S ^TMP("PXBDCPT",$J,"START")=0,FIRST=1,FIRSTCPT=1,PXBEXIT=1
26 ;
27TEST3 ;---THIRD SERERIO FOR PROMPTING FOR CPT'S
28 I $G(DOUBLEQQ) S FIRST=1
29 D TERM^PXBCC
30TEST3C ;--Display the CPT codes
31 D HEADER
32 ;---ADDED 11/4/96
33 D RSET^PXBDREQ("PRV")
34 ;------END--------
35R2 K ERROR,PXMODSTR
36 S (PXNEWIEN,PXMREQ)=""
37 D CPT^PXBPCPT G:$G(PXBEXIT)<1 CPTXIT G:$G(ERROR) R2 W IOEDEOP
38 I DATA["^C" D RSET^PXBDREQ("CPT") K PXMREQ G TEST3C
39 I DATA=""!(DATA["^") D RSET^PXBDREQ("CPT") K DIRUT,PXBUT,PXMREQ G CPTXIT
40 ;
41 ;--Display the requested CPT code
42 D PRINT^PXBDREQ(2)
43 ;
44 ;--Prompt for CPT Modifiers
45 D FULL0^PXBCC
46 S PXNEWIEN=""
47 S PXMDCNT=$$CODM^ICPTCOD($P(REQI,"^",3),"^TMP(""PXMODARR"",$J",PXBSOURC,PXBVSTDT)
48 K ^TMP("PXMODARR",$J)
49 D MOD^PXBPMOD(PXBVST,PXBPAT,$P(REQI,"^",3),$G(PXMODSTR),$P(REQI,"^",8),IDATE,PXMDCNT,.PXMREQ)
50 I DATA["^C" D RSET^PXBDREQ("CPT") K PXMREQ G TEST3
51 I PXNEWIEN]"" S PXBNCPT($P(REQI,"^",3),PXNEWIEN)=""
52 ;
53TEST3Q ;--Prompt of the QUANTITY of the CPT code
54 S DEL=0
55 D WIN17^PXBCC(PXBCNT)
56 D QUA^PXBPQUA S PROMPT="CPT"
57 I EDATA["^C" D G TEST3
58 .I PXNEWIEN]"" D REMOVE^PXCEVFIL(PXNEWIEN)
59 .D RSET^PXBDREQ("CPT") K PXMREQ
60 ;
61 ;--Create The ^TMP("PXK", ARRAY
62 S COM="0@" I COM[$P(REQI,"^",4) D
63 .D EN0^PXBSTOR(PXBVST,PATIENT,REQI,.PXMREQ)
64 .D EN1^PXKMAIN
65 .S DEL=1
66 ;--File the data into the V files
67 I $G(DEL)=1 D G TEST3C
68 .I PXNEWIEN]"" D REMOVE^PXCEVFIL(PXNEWIEN)
69 ;
70TEST3P ;--GET PROVIDER
71 D PRV^PXBGPRV(PXBVST,.PXBSKY,.PXBKY,.PXBSAM,.PXBCNT,.PRVDR,.FPRI) W IOSC
72 S FROM="CPT" D PRV^PXBPPRV I DATA["^P" D W IOCUU G TEST3P
73 .S $P(REQI,"^",1)="",$P(REQI,"^",2)="",$P(REQI,"^",7)=""
74 .K PXBDPRV
75TEST3O ;ORDERING PROVIDER - PX124
76 D ORD^PXBPORD
77 I DATA["^O" D W IOCUU G TEST3O
78 .S $P(REQI,U,22)=""
79TEST3D ;UP TO 8 DIAGNOSES - PX124
80 S (PXBDXPRI,PX124)="",DATA=1
81 F S PX124=$O(^AUPNVPOV("AD",PXBVST,PX124)) Q:'PX124!PXBDXPRI D
82 .I $P(^AUPNVPOV(PX124,0),U,12)="P" S PXBDXPRI=$P(^(0),U,1)
83 F PX124=1:1:8 Q:DATA=""!(DATA["^")&$$MORE(PX124) D DX(PX124)
84 ;
85STORE ;SAVE IN V FILES
86 D EN0^PXBSTOR(PXBVST,PATIENT,REQI,.PXMREQ)
87 D EN1^PXKMAIN
88 D RSET^PXBDREQ("CPT") ;--RSET^PXBDREQ("PRV")
89 K PXMREQ
90 S $P(REQI,"^",7)=""
91 G TEST3C
92 ;
93HEADER ;--Display header and list CPT codes and associated modifiers
94 D HDR^PXBUTL(PXBVST,1)
95 D REQ^PXBDREQ(4)
96 D LOC^PXBCC(3,1)
97 W IOEDEOP
98 D CPT^PXBGCPT(PXBVST)
99 D EN0^PXBDCPT
100 D WIN17^PXBCC(PXBCNT)
101 D LOC^PXBCC(15,1)
102 Q
103 ;
104CPTXIT ;----EXIT AND CLEAN UP
105 D KILL^PXBUTL3
106 D PRIM^PXBUTL
107 D FULL0^PXBCC
108 D CLEAR1^PXBCC
109 K PXBKY,PXBSAM,PXBSKY,PXKVST
110 ;
111 ;----Do the EVENT to the Protocol
112 ;D EVENT^PXKMAIN
113 K ^TMP("PXBDCPT",$J),^TMP("PXBSTOR",$J),^TMP("PXK",$J)
114 K ^TMP("PXBTOTAL",$J),^TMP("PXBTANA",$J)
115 Q
116 ;
117DX(PXC) ;GET DIAGNOSIS - PX124
118DX2 ;2nd entry
119 D CDX^PXBPCPT2(PXC)
120 I DATA["^D" D W IOCUU G DX2
121 .S $P(REQI,U,PXC+11)=""
122 Q:DATA["^"!(DATA["@")
123 D PRINT^PXBDREQ(PXC+5),WIN17^PXBCC(PXBCNT),LOC^PXBCC(15,1)
124 W IOSC,IOEDEOP,IORC
125 Q
126 ;
127MORE(PXC) ;MORE DXs? - PX124
128 Q:PXC=19 0 ;last in list - NO More DXs
129 N PX,ANS
130 S ANS=0
131 F PX=PXC+1:1:19 I $P(REQI,U,PX) S ANS=1 Q
132 Q ANS
133 ;
Note: See TracBrowser for help on using the repository browser.