PXBPORD ;ISL/JVS - PROMPT ORDERING PROVIDER ; 6/27/07 6:45pm
;;1.0;PCE PATIENT CARE ENCOUNTER;**124,186**;Aug 12, 1996;Build 3
;
ORD ;--Ordering Provider
N TIMED,DATA,DIC,X,Y,CPTORD
S CPTORD=$S($P(REQI,U,22):$P(^VA(200,$P(REQI,U,22),0),U,1),1:"")
S TIMED="I '$T!(DATA[""^"")"
D WIN17^PXBCC(PXBCNT),LOC^PXBCC(16,0)
W IOSC,IOEDEOP
O ;--SECOND ENTRY POINT
; begin patch *186*
;W IORC," Enter Ordering Provider: "_$G(CPTORD)_"//",IOELEOL
W IORC," Enter Ordering Provider: "_$G(CPTORD)_" // "
W IOSC,IOELEOL
; end patch *186*
R DATA:DTIME
O1 ;---
X TIMED I G ORDX
I DATA="@" S $P(REQI,"^",22)="@" G ORDX
I DATA="^"!(DATA="^^")!(DATA["^O") G ORDX
;I DATA="?" D EN1^PXBHLP0("PXB","ORD",1,"",1) G O
;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
I DATA="?" D HELP^PXBUTL0("OP1") G O
I DATA="??" D HELP^PXBUTL0("OP2") G O
I DATA="",$G(CPTORD)'="" S DATA=CPTORD
I DATA="" G ORDX
D CASE^PXBUTL
;----SPACE BAR---
I DATA'=" ",DATA'["^",DATA'="" S ^DISV(DUZ,"PXBORD-22")=DATA
I DATA=" ",$D(^DISV(DUZ,"PXBORD-22")) S DATA=^DISV(DUZ,"PXBORD-22") W DATA
;--If a "?" is NOT entered during lookup
; begin patch *186*
; S X=DATA,DIC=200,DIC(0)="OQME" D ^DIC
; I Y=-1 S $P(REQE,U,22)="" G ORDX
S DIC("S")="I $$ACTIVPRV^PXAPI(Y,$G(IDATE,DT))"
S X=DATA,DIC=200,DIC(0)="OQME" D ^DIC
I +Y>0 D
. W IORC W:$G(CPTORD)'=X X W IOEDEOP
E D G O
. N EDATA S EDATA=X
. D LOC^PXBCC(16,0),HELP^PXBUTL0("PRVM")
. D HELP1^PXBUTL1("CON") R X:DTIME
. D LOC^PXBCC(16,0) W IOSC,IOEDEOP
; end patch *186*
;
S $P(REQI,U,22)=+Y,$P(REQE,U,22)=$P(Y,U,2)
ORDX ;--EXIT AND CLEANUP
I '$D(REQE) S REQE=""
I $P(REQE,U,22)="" S $P(REQI,U,22)=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPXBPORD 1850 printed Dec 13, 2024@02:27:08 Page 2
PXBPORD ;ISL/JVS - PROMPT ORDERING PROVIDER ; 6/27/07 6:45pm
+1 ;;1.0;PCE PATIENT CARE ENCOUNTER;**124,186**;Aug 12, 1996;Build 3
+2 ;
ORD ;--Ordering Provider
+1 NEW TIMED,DATA,DIC,X,Y,CPTORD
+2 SET CPTORD=$SELECT($PIECE(REQI,U,22):$PIECE(^VA(200,$PIECE(REQI,U,22),0),U,1),1:"")
+3 SET TIMED="I '$T!(DATA[""^"")"
+4 DO WIN17^PXBCC(PXBCNT)
DO LOC^PXBCC(16,0)
+5 WRITE IOSC,IOEDEOP
O ;--SECOND ENTRY POINT
+1 ; begin patch *186*
+2 ;W IORC," Enter Ordering Provider: "_$G(CPTORD)_"//",IOELEOL
+3 WRITE IORC," Enter Ordering Provider: "_$GET(CPTORD)_" // "
+4 WRITE IOSC,IOELEOL
+5 ; end patch *186*
+6 READ DATA:DTIME
O1 ;---
+1 XECUTE TIMED
IF $TEST
GOTO ORDX
+2 IF DATA="@"
SET $PIECE(REQI,"^",22)="@"
GOTO ORDX
+3 IF DATA="^"!(DATA="^^")!(DATA["^O")
GOTO ORDX
+4 ;I DATA="?" D EN1^PXBHLP0("PXB","ORD",1,"",1) G O
+5 ;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
+6 IF DATA="?"
DO HELP^PXBUTL0("OP1")
GOTO O
+7 IF DATA="??"
DO HELP^PXBUTL0("OP2")
GOTO O
+8 IF DATA=""
IF $GET(CPTORD)'=""
SET DATA=CPTORD
+9 IF DATA=""
GOTO ORDX
+10 DO CASE^PXBUTL
+11 ;----SPACE BAR---
+12 IF DATA'=" "
IF DATA'["^"
IF DATA'=""
SET ^DISV(DUZ,"PXBORD-22")=DATA
+13 IF DATA=" "
IF $DATA(^DISV(DUZ,"PXBORD-22"))
SET DATA=^DISV(DUZ,"PXBORD-22")
WRITE DATA
+14 ;--If a "?" is NOT entered during lookup
+15 ; begin patch *186*
+16 ; S X=DATA,DIC=200,DIC(0)="OQME" D ^DIC
+17 ; I Y=-1 S $P(REQE,U,22)="" G ORDX
+18 SET DIC("S")="I $$ACTIVPRV^PXAPI(Y,$G(IDATE,DT))"
+19 SET X=DATA
SET DIC=200
SET DIC(0)="OQME"
DO ^DIC
+20 IF +Y>0
Begin DoDot:1
+21 WRITE IORC
if $GET(CPTORD)'=X
WRITE X
WRITE IOEDEOP
End DoDot:1
+22 IF '$TEST
Begin DoDot:1
+23 NEW EDATA
SET EDATA=X
+24 DO LOC^PXBCC(16,0)
DO HELP^PXBUTL0("PRVM")
+25 DO HELP1^PXBUTL1("CON")
READ X:DTIME
+26 DO LOC^PXBCC(16,0)
WRITE IOSC,IOEDEOP
End DoDot:1
GOTO O
+27 ; end patch *186*
+28 ;
+29 SET $PIECE(REQI,U,22)=+Y
SET $PIECE(REQE,U,22)=$PIECE(Y,U,2)
ORDX ;--EXIT AND CLEANUP
+1 IF '$DATA(REQE)
SET REQE=""
+2 IF $PIECE(REQE,U,22)=""
SET $PIECE(REQI,U,22)=""
+3 QUIT
