PXBPORD.m

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 ---PXBPORD   1850     printed  Mar 13, 2025@21:31:51                                                                                                                                                                                                     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