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

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

initial load of WorldVistAEHR

File size: 1.8 KB
RevLine 
[613]1PXBPORD ;ISL/JVS - PROMPT ORDERING PROVIDER ; 6/27/07 6:45pm
2 ;;1.0;PCE PATIENT CARE ENCOUNTER;**124,186**;Aug 12, 1996;Build 3
3 ;
4ORD ;--Ordering Provider
5 N TIMED,DATA,DIC,X,Y,CPTORD
6 S CPTORD=$S($P(REQI,U,22):$P(^VA(200,$P(REQI,U,22),0),U,1),1:"")
7 S TIMED="I '$T!(DATA[""^"")"
8 D WIN17^PXBCC(PXBCNT),LOC^PXBCC(16,0)
9 W IOSC,IOEDEOP
10O ;--SECOND ENTRY POINT
11 ; begin patch *186*
12 ;W IORC," Enter Ordering Provider: "_$G(CPTORD)_"//",IOELEOL
13 W IORC," Enter Ordering Provider: "_$G(CPTORD)_" // "
14 W IOSC,IOELEOL
15 ; end patch *186*
16 R DATA:DTIME
17O1 ;---
18 X TIMED I G ORDX
19 I DATA="@" S $P(REQI,"^",22)="@" G ORDX
20 I DATA="^"!(DATA="^^")!(DATA["^O") G ORDX
21 ;I DATA="?" D EN1^PXBHLP0("PXB","ORD",1,"",1) G O
22 ;I DATA="??" S DOUBLEQQ=1 D EN1^PXBHLP0("PXB","ORD","",1,2) S:DATA="O" UDATA="^O" S:$L(DATA,"^")>1 (Y,DATA,EDATA)=$P(DATA,"^",2) S:$G(UDATA)="" UDATA="^O" S:UDATA="^O" (DATA,EDATA,Y)=UDATA G:UDATA="^O" O1
23 I DATA="?" D HELP^PXBUTL0("OP1") G O
24 I DATA="??" D HELP^PXBUTL0("OP2") G O
25 I DATA="",$G(CPTORD)'="" S DATA=CPTORD
26 I DATA="" G ORDX
27 D CASE^PXBUTL
28 ;----SPACE BAR---
29 I DATA'=" ",DATA'["^",DATA'="" S ^DISV(DUZ,"PXBORD-22")=DATA
30 I DATA=" ",$D(^DISV(DUZ,"PXBORD-22")) S DATA=^DISV(DUZ,"PXBORD-22") W DATA
31 ;--If a "?" is NOT entered during lookup
32 ; begin patch *186*
33 ; S X=DATA,DIC=200,DIC(0)="OQME" D ^DIC
34 ; I Y=-1 S $P(REQE,U,22)="" G ORDX
35 S DIC("S")="I $$ACTIVPRV^PXAPI(Y,$G(IDATE,DT))"
36 S X=DATA,DIC=200,DIC(0)="OQME" D ^DIC
37 I +Y>0 D
38 . W IORC W:$G(CPTORD)'=X X W IOEDEOP
39 E D G O
40 . N EDATA S EDATA=X
41 . D LOC^PXBCC(16,0),HELP^PXBUTL0("PRVM")
42 . D HELP1^PXBUTL1("CON") R X:DTIME
43 . D LOC^PXBCC(16,0) W IOSC,IOEDEOP
44 ; end patch *186*
45 ;
46 S $P(REQI,U,22)=+Y,$P(REQE,U,22)=$P(Y,U,2)
47ORDX ;--EXIT AND CLEANUP
48 I '$D(REQE) S REQE=""
49 I $P(REQE,U,22)="" S $P(REQI,U,22)=""
50 Q
Note: See TracBrowser for help on using the repository browser.