ORCMENU1 ;SLC/MKB-Add Orders cont ;2/7/97 15:41
;;3.0;ORDER ENTRY/RESULTS REPORTING;**7,36,55,48,92**;Dec 17, 1997
ORDCHK ; -- Order Checking [called from ORCSIGN]
; Returns ORQUIT=1 if ^ or timeout
N ORCHECK,ORIFN,ORY,ORTX,ORIGVIEW
D SESSION^ORCHECK Q:'$G(ORCHECK)
W !,"Unsigned orders with order checks:"
S (ORIFN,ORY)=0 F S ORIFN=$O(ORCHECK(ORIFN)) Q:ORIFN'>0 D
. S ORY=ORY+1,ORY(ORY)=ORIFN,ORIGVIEW=2 D TEXT^ORQ12(.ORTX,ORIFN,70)
. W !!,$J(ORY,3)_". "_$G(ORTX(1))_$S($O(ORTX(1)):" ...",1:"")
. D LIST^ORCHECK(ORIFN)
OC1 I $$CANCEL^ORCHECK D ; cancel order(s)
. N X,Y,Z,DIR,NMBR,DIK,DA,ORI S:ORY=1 Y=1
. I ORY'=1 S DIR(0)="LA^1:"_ORY,DIR("A")="Select orders: ",DIR("?")="Enter the orders you wish to cancel, as a range or list of numbers" D ^DIR Q:$D(DTOUT)!($D(DUOUT))
. S NMBR=Y,DIK="^OR(100,"
. F ORI=1:1:$L(NMBR,",") S X=$P(NMBR,",",ORI) I X D
. . S DA=+$G(ORY(X)) Q:'DA D ^DIK,UNLK1^ORX2(DA)
. . K ORES(DA_";1"),^TMP("ORNEW",$J,DA,1),ORCHECK(DA),ORY(X) S ORY=ORY-1
. W !?10,"... orders cancelled.",!
OC2 Q:ORY'>0 ; all orders cancelled
S ORIFN=0 F S ORIFN=$O(ORCHECK(ORIFN)) Q:ORIFN'>0 I $D(ORCHECK(ORIFN,1)) W !!,"Critical order checks remain that require a justification." S ORCHECK("OK")=$$REASON^ORCHECK Q
I $G(ORCHECK("OK"))="^" S ORQUIT=1 K ORCHECK("OK") ; save unsigned
S ORIFN=0 F S ORIFN=$O(ORCHECK(ORIFN)) Q:ORIFN'>0 D OC^ORCSAVE2
Q
;
LOCATION(ORQ,ORB,ORS) ; -- Returns patient location
; Optional: ORQ = 1 if not required
; ORB = Default value in vptr format
; ORS = String of location types to allow
;
N X,Y,DIR S:'$L($G(ORS)) ORS="CZW" ;assume Clinic, Other, Ward
S DIR(0)="PA"_$S($G(ORQ):"O",1:"")_"^44:AEQM",DIR("A")="Patient Location: "
S DIR("S")="I ORS[$P(^(0),U,3),'$P($G(^(""OOS"")),""^"")"
S DIR("?")="Enter the patient's current location."
S:$G(ORB) DIR("B")=$P($G(^SC(+ORB,0)),U)
LOC1 D ^DIR S:Y>0 Y=+Y_";SC(" S:Y'>0 Y="^"
I Y,'$$ACTLOC^ORWU(+Y) W $C(7),!,"This location is inactive!" G LOC1
Q Y
;
PROVIDER(ASK) ; -- Return ordering provider [ASK=1: force prompting]
N X,Y,DIC,DFN,%
I '$G(ASK),$D(^XUSEC("ORES",DUZ)),$D(^XUSEC("PROVIDER",DUZ)) D Q Y
. S Y=DUZ Q:'$G(ORNP) Q:ORNP=DUZ ;no change, else show current prov
. S Y=+ORNP W !,"Requesting CLINICIAN: "_$P($G(^VA(200,Y,0)),U) H 1
S Y=$$OUTPTPR^SDUTL3(+ORVP) W:Y !,"Primary Care Physician is "_$P(Y,U,2),!
I $$GET^XPAR("ALL","ORPF DEFAULT PROVIDER") S:$G(ORNP) DIC("B")=$P($G(^VA(200,+ORNP,0)),U) I '$G(ORNP),$D(^XUSEC("PROVIDER",DUZ)),'$$GET^XPAR("ALL","ORPF RESTRICT REQUESTOR")!$D(^XUSEC("ORES",DUZ)) S DIC("B")=DUZ
P S DIC=200,DIC(0)="AEQM",DIC("A")="Requesting CLINICIAN: " ;D=AK.PROVIDER
S DIC("S")="I $D(^VA(200,""AK.PROVIDER"",$P(^(0),U)))"
D ^DIC S:Y>0 Y=+Y I Y'>0 S Y="^" G PQ
I Y,'$$PROVIDER^XUSER(+Y) W $C(7),!,"This provider is no longer active!" G P ;IA#2343
I +Y=DUZ S X=$$GET^XPAR("ALL","ORPF RESTRICT REQUESTOR") I X,$S($D(^XUSEC("ORELSE",DUZ)):1,$D(^XUSEC("OREMAS",DUZ))&(X=2):1,1:0) W !!,"You are not allowed to choose yourself as the Requesting Clinician",! G P
S X=$$GET^XPAR("ALL","ORPF CONFIRM PROVIDER") I X G:(X=2&($D(^XUSEC("ORES",DUZ)))) PQ W !!,"Requesting Clinician: "_$P(^VA(200,+Y,0),"^")_" Are you sure" S %=$S(X=3:1,1:2) D YN^DICN I %'=1 G P
PQ Q Y
;
SPEC(EVENT) ; -- Return treating specialty
N X,Y,DIC S:'$L($G(EVENT)) EVENT="" D FULL^VALM1 S VALMBCK="R"
S DIC="^DIC(45.7,",DIC(0)="AEQM",DIC("S")="I $$ACTIVE^DGACT(45.7,Y)",D="B^AHN"
S DIC("A")=$S(EVENT="A":"Admit to Specialty: ",EVENT="T":"Transfer to Specialty: ",1:"Treating Specialty: ")
D MIX^DIC1 S:$D(DTOUT)!$D(DUOUT)!(Y'>0) Y="^"
Q Y
;
CHANGE ; -- Change location and/or provider
N ORRV,ORX,ORCHNGD I $D(^TMP("ORNEW",$J)) D
. W !!,"There are new orders for this patient from the current location or provider!"
. H 1 S ORRV=1 D EN^ORCMENU2,NOTIF^ORCMENU2 ;EX^ORCMENU2 in Exit Action
D FULL^VALM1 S VALMBCK="R",ORCHNGD=0
W !!,"NOTE: You may now select a new ordering location and/or provider."
W !,"===== These changes will remain in effect until the chart is closed unless",!," these values are changed again!",!,$C(7)
S ORX=$$LOCATION(0,ORL) Q:ORX="^"
I ORX,ORX'=ORL S ORL=ORX,ORL(0)=$P($G(^SC(+ORL,0)),U),ORL(1)="",ORCHNGD=1 K ^TMP("ORNEW",$J),VALMHDR
S ORX=$$PROVIDER(1) I ORX,ORX'=$G(ORNP) S ORNP=ORX,ORCHNGD=1
W !?10,"... "_$S(ORCHNGD:"changes now effective!",1:"nothing changed!")
H 1 Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORCMENU1 4458 printed Sep 23, 2025@20:05:02 Page 2
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**7,36,55,48,92**;Dec 17, 1997
ORDCHK ; -- Order Checking [called from ORCSIGN]
+1 ; Returns ORQUIT=1 if ^ or timeout
+2 NEW ORCHECK,ORIFN,ORY,ORTX,ORIGVIEW
+3 DO SESSION^ORCHECK
if '$GET(ORCHECK)
QUIT
+4 WRITE !,"Unsigned orders with order checks:"
+5 SET (ORIFN,ORY)=0
FOR
SET ORIFN=$ORDER(ORCHECK(ORIFN))
if ORIFN'>0
QUIT
Begin DoDot:1
+6 SET ORY=ORY+1
SET ORY(ORY)=ORIFN
SET ORIGVIEW=2
DO TEXT^ORQ12(.ORTX,ORIFN,70)
+7 WRITE !!,$JUSTIFY(ORY,3)_". "_$GET(ORTX(1))_$SELECT($ORDER(ORTX(1)):" ...",1:"")
+8 DO LIST^ORCHECK(ORIFN)
End DoDot:1
OC1 ; cancel order(s)
IF $$CANCEL^ORCHECK
Begin DoDot:1
+1 NEW X,Y,Z,DIR,NMBR,DIK,DA,ORI
if ORY=1
SET Y=1
+2 IF ORY'=1
SET DIR(0)="LA^1:"_ORY
SET DIR("A")="Select orders: "
SET DIR("?")="Enter the orders you wish to cancel, as a range or list of numbers"
DO ^DIR
if $DATA(DTOUT)!($DATA(DUOUT))
QUIT
+3 SET NMBR=Y
SET DIK="^OR(100,"
+4 FOR ORI=1:1:$LENGTH(NMBR,",")
SET X=$PIECE(NMBR,",",ORI)
IF X
Begin DoDot:2
+5 SET DA=+$GET(ORY(X))
if 'DA
QUIT
DO ^DIK
DO UNLK1^ORX2(DA)
+6 KILL ORES(DA_";1"),^TMP("ORNEW",$JOB,DA,1),ORCHECK(DA),ORY(X)
SET ORY=ORY-1
End DoDot:2
+7 WRITE !?10,"... orders cancelled.",!
End DoDot:1
OC2 ; all orders cancelled
if ORY'>0
QUIT
+1 SET ORIFN=0
FOR
SET ORIFN=$ORDER(ORCHECK(ORIFN))
if ORIFN'>0
QUIT
IF $DATA(ORCHECK(ORIFN,1))
WRITE !!,"Critical order checks remain that require a justification."
SET ORCHECK("OK")=$$REASON^ORCHECK
QUIT
+2 ; save unsigned
IF $GET(ORCHECK("OK"))="^"
SET ORQUIT=1
KILL ORCHECK("OK")
+3 SET ORIFN=0
FOR
SET ORIFN=$ORDER(ORCHECK(ORIFN))
if ORIFN'>0
QUIT
DO OC^ORCSAVE2
+4 QUIT
+5 ;
LOCATION(ORQ,ORB,ORS) ; -- Returns patient location
+1 ; Optional: ORQ = 1 if not required
+2 ; ORB = Default value in vptr format
+3 ; ORS = String of location types to allow
+4 ;
+5 ;assume Clinic, Other, Ward
NEW X,Y,DIR
if '$LENGTH($GET(ORS))
SET ORS="CZW"
+6 SET DIR(0)="PA"_$SELECT($GET(ORQ):"O",1:"")_"^44:AEQM"
SET DIR("A")="Patient Location: "
+7 SET DIR("S")="I ORS[$P(^(0),U,3),'$P($G(^(""OOS"")),""^"")"
+8 SET DIR("?")="Enter the patient's current location."
+9 if $GET(ORB)
SET DIR("B")=$PIECE($GET(^SC(+ORB,0)),U)
LOC1 DO ^DIR
if Y>0
SET Y=+Y_";SC("
if Y'>0
SET Y="^"
+1 IF Y
IF '$$ACTLOC^ORWU(+Y)
WRITE $CHAR(7),!,"This location is inactive!"
GOTO LOC1
+2 QUIT Y
+3 ;
PROVIDER(ASK) ; -- Return ordering provider [ASK=1: force prompting]
+1 NEW X,Y,DIC,DFN,%
+2 IF '$GET(ASK)
IF $DATA(^XUSEC("ORES",DUZ))
IF $DATA(^XUSEC("PROVIDER",DUZ))
Begin DoDot:1
+3 ;no change, else show current prov
SET Y=DUZ
if '$GET(ORNP)
QUIT
if ORNP=DUZ
QUIT
+4 SET Y=+ORNP
WRITE !,"Requesting CLINICIAN: "_$PIECE($GET(^VA(200,Y,0)),U)
HANG 1
End DoDot:1
QUIT Y
+5 SET Y=$$OUTPTPR^SDUTL3(+ORVP)
if Y
WRITE !,"Primary Care Physician is "_$PIECE(Y,U,2),!
+6 IF $$GET^XPAR("ALL","ORPF DEFAULT PROVIDER")
if $GET(ORNP)
SET DIC("B")=$PIECE($GET(^VA(200,+ORNP,0)),U)
IF '$GET(ORNP)
IF $DATA(^XUSEC("PROVIDER",DUZ))
IF '$$GET^XPAR("ALL","ORPF RESTRICT REQUESTOR")!$DATA(^XUSEC("ORES",DUZ))
SET DIC("B")=DUZ
P ;D=AK.PROVIDER
SET DIC=200
SET DIC(0)="AEQM"
SET DIC("A")="Requesting CLINICIAN: "
+1 SET DIC("S")="I $D(^VA(200,""AK.PROVIDER"",$P(^(0),U)))"
+2 DO ^DIC
if Y>0
SET Y=+Y
IF Y'>0
SET Y="^"
GOTO PQ
+3 ;IA#2343
IF Y
IF '$$PROVIDER^XUSER(+Y)
WRITE $CHAR(7),!,"This provider is no longer active!"
GOTO P
+4 IF +Y=DUZ
SET X=$$GET^XPAR("ALL","ORPF RESTRICT REQUESTOR")
IF X
IF $SELECT($DATA(^XUSEC("ORELSE",DUZ)):1,$DATA(^XUSEC("OREMAS",DUZ))&(X=2):1,1:0)
WRITE !!,"You are not allowed to choose yourself as the Requesting Clinician",!
GOTO P
+5 SET X=$$GET^XPAR("ALL","ORPF CONFIRM PROVIDER")
IF X
if (X=2&($DATA(^XUSEC("ORES",DUZ))))
GOTO PQ
WRITE !!,"Requesting Clinician: "_$PIECE(^VA(200,+Y,0),"^")_" Are you sure"
SET %=$SELECT(X=3:1,1:2)
DO YN^DICN
IF %'=1
GOTO P
PQ QUIT Y
+1 ;
SPEC(EVENT) ; -- Return treating specialty
+1 NEW X,Y,DIC
if '$LENGTH($GET(EVENT))
SET EVENT=""
DO FULL^VALM1
SET VALMBCK="R"
+2 SET DIC="^DIC(45.7,"
SET DIC(0)="AEQM"
SET DIC("S")="I $$ACTIVE^DGACT(45.7,Y)"
SET D="B^AHN"
+3 SET DIC("A")=$SELECT(EVENT="A":"Admit to Specialty: ",EVENT="T":"Transfer to Specialty: ",1:"Treating Specialty: ")
+4 DO MIX^DIC1
if $DATA(DTOUT)!$DATA(DUOUT)!(Y'>0)
SET Y="^"
+5 QUIT Y
+6 ;
CHANGE ; -- Change location and/or provider
+1 NEW ORRV,ORX,ORCHNGD
IF $DATA(^TMP("ORNEW",$JOB))
Begin DoDot:1
+2 WRITE !!,"There are new orders for this patient from the current location or provider!"
+3 ;EX^ORCMENU2 in Exit Action
HANG 1
SET ORRV=1
DO EN^ORCMENU2
DO NOTIF^ORCMENU2
End DoDot:1
+4 DO FULL^VALM1
SET VALMBCK="R"
SET ORCHNGD=0
+5 WRITE !!,"NOTE: You may now select a new ordering location and/or provider."
+6 WRITE !,"===== These changes will remain in effect until the chart is closed unless",!," these values are changed again!",!,$CHAR(7)
+7 SET ORX=$$LOCATION(0,ORL)
if ORX="^"
QUIT
+8 IF ORX
IF ORX'=ORL
SET ORL=ORX
SET ORL(0)=$PIECE($GET(^SC(+ORL,0)),U)
SET ORL(1)=""
SET ORCHNGD=1
KILL ^TMP("ORNEW",$JOB),VALMHDR
+9 SET ORX=$$PROVIDER(1)
IF ORX
IF ORX'=$GET(ORNP)
SET ORNP=ORX
SET ORCHNGD=1
+10 WRITE !?10,"... "_$SELECT(ORCHNGD:"changes now effective!",1:"nothing changed!")
+11 HANG 1
QUIT
