ORWD ; SLC/KCM - Utilities for Windows Dialogs ;7/2/01 13:31
;;3.0;ORDER ENTRY/RESULTS REPORTING;**243,280**;Dec 17, 1997;Build 85
;
DT(Y,X) ; Returns internal Fileman Date/Time
N %DT S %DT="TS" D ^%DT
Q
PROVKEY(VAL,USERID) ; Returns 1 if user possesses the provider key
N NAM S NAM=$P(^VA(200,USERID,0),U,1)
S VAL=$D(^VA(200,"AK.PROVIDER",NAM,USERID))
Q
KEY(VAL,KEYNAME,USERID) ; Returns 1 if user possesses the key
S VAL=0 I $D(^XUSEC(KEYNAME,USERID)) S VAL=1
Q
OI(Y,XREF,DIR,FROM) ; Return a bolus of orderable items
; .Return Array, Cross Reference (S.xxx), Direction, Starting Text
N I,IEN,CNT S CNT=44
;
I DIR=0 D ; Forward direction
. F I=1:1:CNT S FROM=$O(^ORD(101.43,XREF,FROM)) Q:FROM="" D
. . S Y(I)=$O(^ORD(101.43,XREF,FROM,0))_"^"_FROM
. I $G(Y(CNT))="" S Y(I)=""
;
I DIR=1 D ; Reverse direction
. F I=1:1:CNT S FROM=$O(^ORD(101.43,XREF,FROM),-1) Q:FROM="" D
. . S Y(I)=$O(^ORD(101.43,XREF,FROM,0))_"^"_FROM
Q
ODEF(Y,DLG) ; Return the definition for a dialog
Q:'$L(DLG)
S DLG=+$O(^ORD(101.41,"B",DLG,0))
Q:$D(^ORD(101.41,DLG,50))<10
N I,IEN,IDX
S I=0,IDX=0
S Y(0)=$P($G(^ORD(101.41,DLG,5)),"^",4)
F S I=$O(^ORD(101.41,DLG,50,"AC",I)) Q:I="" S IEN=$O(^(I,0)) D
. S IDX=IDX+1,Y(IDX)=$G(^ORD(101.41,DLG,50,IEN,0))
Q
DEF(Y,DLG) ; Return format mapping for a dialog
; Y(n): CtrlName^DlgPtr^FmtSeq^Fmt^Omit^Lead^Trail^Mult?^chd1~chd2~...
I DLG="NOT IMPLEMENTED" S Y(0)="0^0" Q ; for testing
S DLG=$O(^ORD(101.41,"B",DLG,0))
N I,J,K,N,X0,X2,XW,DPTR
S Y(0)=$P(^ORD(101.41,DLG,0),U,5)_U_DLG
S I=0,N=0
F S I=$O(^ORD(101.41,DLG,10,I)) Q:I'>0 D
. S X0=$G(^ORD(101.41,DLG,10,I,0)),DPTR=$P(X0,U,2)
. S X2=$G(^ORD(101.41,DLG,10,I,2))
. S XW=$G(^ORD(101.41,DLG,10,I,"W"))
. S N=N+1,Y(N)=$P(XW,U,1)_U_DPTR_U_X2,CHLD=""
. S J=0 F S J=$O(^ORD(101.41,DLG,10,"DAD",DPTR,J)) Q:'J D
. . S K=0 F S K=$O(^ORD(101.41,DLG,10,"DAD",DPTR,J,K)) Q:'K D
. . . S CHLD=CHLD_$P(^ORD(101.41,DLG,10,K,0),U,2)_"~"
. S $P(Y(N),U,8)=CHLD
Q
FORMID(VAL,ORIFN) ; procedure
; Returns the Dialog Form ID
N X
S VAL=0,X=$P(^OR(100,+ORIFN,0),U,5)
Q:$P(X,";",2)'="ORD(101.41,"
S VAL=+$P($G(^ORD(101.41,+X,5)),U,5)
; I X S VAL=$P($G(^XTV(8989.52,+X,0)),U,2)
Q
GET4EDIT(LST,ORIFN) ; procedure
; return responses in format that can be used by dialog
N ILST,PRMT,INST,DLG,ORDIALOG S ILST=0
I '$D(ORIFN) S LST=0 Q
S ORIFN=+ORIFN,DLG=+$P(^OR(100,ORIFN,0),U,5)
D GETDLG1^ORCD(DLG),GETORDER^ORCD("^OR(100,"_ORIFN_",4.5)")
S PRMT=0 F S PRMT=$O(ORDIALOG(PRMT)) Q:'PRMT D
. S INST=0 F S INST=$O(ORDIALOG(PRMT,INST)) Q:'INST D
. . S ILST=ILST+1,LST(ILST)="~"_PRMT_U_INST_U_$P(ORDIALOG(PRMT),U,3)
. . S ILST=ILST+1,LST(ILST)="d"_ORDIALOG(PRMT,INST)
. . I $E(ORDIALOG(PRMT,INST))=U D ; load word processing
. . . N I,REF S I=0,REF=ORDIALOG(PRMT,INST)
. . . F S I=$O(@REF@(I)) Q:'I S ILST=ILST+1,LST(ILST)="t"_^(I,0)
. . E S $P(LST(ILST),U,2)=$$EXT^ORCD(PRMT,INST) ; load external value
. . I "R"[$E(ORDIALOG(PRMT,0)) D
. . . S $P(LST(ILST),U,2)=$$UP^XLFSTR($$FMTE^XLFDT(ORDIALOG(PRMT,INST)))
Q
EXTDT(X) ; Return an external date time that can be interpreted by %DT
I $E(X)="T" Q "TODAY"_$E(X,2,255)
I $E(X)="V" Q "NEXT VISIT"_$E(X,2,255)
Q ""
SAVE(Y,DFN,ORNP,LOC,DLG,ORWDACT,RSP) ; procedure
; Save order
N ORDIALOG,ORL,ORVP,ORIFN,ORDUZ,ORSTS,ORDG,OREVENT,ORCAT,ORDA
I $P(^ORD(101.41,+DLG,0),U)="PSO OERR" S ORCAT="O"
I $P(^ORD(101.41,+DLG,0),U)="PSJ OR PAT OE" S ORCAT="I"
S ORVP=DFN_";DPT(",ORL(2)=LOC_";SC(",ORL=ORL(2)
D GETDLG^ORCD(DLG)
M ORDIALOG=RSP S ORDIALOG=DLG
I ORWDACT="N" D
. D EN^ORCSAVE
. S Y="" I ORIFN D GETBYIFN^ORWORR(.Y,ORIFN)
I $P(ORWDACT,U,1)="E" D
. S ORIFN=+$P(ORWDACT,U,2) D XX^ORCSAVE
. S Y="" S ORIFN=+$P(ORWDACT,U,2)_";"_ORDA D GETBYIFN^ORWORR(.Y,ORIFN)
Q
SIGN(ERRLST,DFN,ORNP,LOC,ORWSIGN) ; procedure
; Sign orders (ORIFN;ACT^RELSTS^SIGSTS^NATR)
N ORVP,ORL,IDX,ANERROR,ERRCNT
S ORVP=DFN_";DPT(",ORL(2)=LOC_";SC(",ORL=ORL(2),ERRCNT=0
I '$D(^XUSEC("ORES",DUZ)) S ERRLST(1)=0_U_"Must have ORES key." Q
S IDX=0 F S IDX=$O(ORWSIGN(IDX)) Q:'IDX S X=ORWSIGN(IDX) D
. ; ** change NATR when GUI changed to pass Nature in 4th piece
. S ORIFN=$P(X,U),RELSTS=$P(X,U,2),SIGSTS=$P(X,U,3),NATR="E" ;$P(X,U,4)
. I SIGSTS=2 D NOTIF^ORCSIGN S ANERROR=""
. I SIGSTS'=2 D EN^ORCSEND(ORIFN,"",SIGSTS,RELSTS,NATR,"",.ANERROR)
. I $L(ANERROR) D Q ; don't print if an error occurred
. . S ERRCNT=ERRCNT+1,ERRLST(ERRCNT)=$P(ORWSIGN(IDX),U)_U_ANERROR
. . K ORWSIGN(IDX)
. I RELSTS=0 K ORWSIGN(IDX) Q ; don't print if unreleased
. S ORWSIGN(IDX)=$P(ORWSIGN(IDX),U)
D PRINTS^ORWD1(.ORWSIGN,LOC)
Q
VALIDACT(VAL,ORIFN,ACTION) ;procedure
; Return 1 if action is valid for this order, otherwise 0^error
S VAL=$$VALID^ORCACT0(ORIFN,ACTION,.ERR)
I VAL=0 S VAL=VAL_U_ERR
Q
SAVEACT(LST,ORIFN,ACTION,REASON,DFN,ORNP,LOC) ;procedure
; Save this action for the order (it is still unsigned/unreleased)
N ORDIALOG,ORL,ORVP,ORDUZ,ORSTS,ORDG,OREVENT,ACTDA,SIGSTS,RELSTS,ASTS
S ORVP=DFN_";DPT(",ORL(2)=LOC_";SC("
S SIGSTS=2,RELSTS=11
I '$P(ORIFN,";",2) S $P(ORIFN,";",2)=1
I (ACTION="FL")!(ACTION="UF")!(ACTION="WC") S SIGSTS=3,RELSTS=""
S ASTS=$P(^OR(100,+ORIFN,8,+$P(ORIFN,";",2),0),U,15)
I ACTION="DC",((ASTS=10)!(ASTS=11)) D Q ; exit here if DELETE
. D GETBYIFN^ORWORR(.LST,ORIFN)
. S $P(LST(1),U,1)="~0",LST(2)="tDELETED - "_$E(LST(2),2,245)
. D CANCEL^ORCSAVE2(ORIFN)
;
; the only valid action for ActDA>1 is deletion, so only orders
; identified by ORIFN;1 should reach this point
;
I $P(ORIFN,";",2)>1 S $ECODE=",Uorder action invalid," Q
I ACTION="FL" S $P(^OR(100,+ORIFN,6),U,1)=1
I ACTION="UF" S $P(^OR(100,+ORIFN,6),U,1)=0
I ACTION'="RN" D
. S ACTDA=$$ACTION^ORCSAVE(ACTION,+ORIFN,ORNP,REASON)
I ACTION="RN" D
. N ORDA,ORDIALOG,PRMT,SAVIFN,X0
. S SAVIFN=+ORIFN,X0=^OR(100,+ORIFN,0)
. I $P(X0,U,5)["101.41," D ; version 3
. . S ORDIALOG=+$P(X0,U,5),ORCAT=$P(^OR(100,+ORIFN,0),U,12)
. . D GETDLG^ORCD(ORDIALOG),GETORDER^ORCD(+ORIFN)
. E D ; version 2.5 generic
. . S ORDIALOG=$O(^ORD(101.41,"B","OR GXTEXT WORD PROCESSING ORDE",0))
. . D GETDLG^ORCD(ORDIALOG)
. . S PRMT=$O(^ORD(101.41,"B","OR GTX WORD PROCESSING 1",0))
. . S ORDIALOG(PRMT,1)=$NA(^TMP("ORWORD",$J,PRMT,1))
. . M ^TMP("ORWORD",$J,PRMT,1)=^OR(100,+ORIFN,1)
. . S PRMT=$O(^ORD(101.41,"B","OR GTX START DATE/TIME",0))
. . I $P(X0,U,9) S ORDIALOG(PRMT,1)=$P(X0,U,9)
. D RN^ORCSAVE I 'ORIFN S $ECODE=",UCPRS renew order,"
. S ACTDA=ORDA,ORIFN=SAVIFN
I (ACTION="FL")!(ACTION="UF") S ACTDA=1
D GETBYIFN^ORWORR(.LST,+ORIFN_";"_ACTDA)
S $P(LST(1),U,12)=ACTDA
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORWD 6812 printed Oct 16, 2024@18:35:43 Page 2
ORWD ; SLC/KCM - Utilities for Windows Dialogs ;7/2/01 13:31
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**243,280**;Dec 17, 1997;Build 85
+2 ;
DT(Y,X) ; Returns internal Fileman Date/Time
+1 NEW %DT
SET %DT="TS"
DO ^%DT
+2 QUIT
PROVKEY(VAL,USERID) ; Returns 1 if user possesses the provider key
+1 NEW NAM
SET NAM=$PIECE(^VA(200,USERID,0),U,1)
+2 SET VAL=$DATA(^VA(200,"AK.PROVIDER",NAM,USERID))
+3 QUIT
KEY(VAL,KEYNAME,USERID) ; Returns 1 if user possesses the key
+1 SET VAL=0
IF $DATA(^XUSEC(KEYNAME,USERID))
SET VAL=1
+2 QUIT
OI(Y,XREF,DIR,FROM) ; Return a bolus of orderable items
+1 ; .Return Array, Cross Reference (S.xxx), Direction, Starting Text
+2 NEW I,IEN,CNT
SET CNT=44
+3 ;
+4 ; Forward direction
IF DIR=0
Begin DoDot:1
+5 FOR I=1:1:CNT
SET FROM=$ORDER(^ORD(101.43,XREF,FROM))
if FROM=""
QUIT
Begin DoDot:2
+6 SET Y(I)=$ORDER(^ORD(101.43,XREF,FROM,0))_"^"_FROM
End DoDot:2
+7 IF $GET(Y(CNT))=""
SET Y(I)=""
End DoDot:1
+8 ;
+9 ; Reverse direction
IF DIR=1
Begin DoDot:1
+10 FOR I=1:1:CNT
SET FROM=$ORDER(^ORD(101.43,XREF,FROM),-1)
if FROM=""
QUIT
Begin DoDot:2
+11 SET Y(I)=$ORDER(^ORD(101.43,XREF,FROM,0))_"^"_FROM
End DoDot:2
End DoDot:1
+12 QUIT
ODEF(Y,DLG) ; Return the definition for a dialog
+1 if '$LENGTH(DLG)
QUIT
+2 SET DLG=+$ORDER(^ORD(101.41,"B",DLG,0))
+3 if $DATA(^ORD(101.41,DLG,50))<10
QUIT
+4 NEW I,IEN,IDX
+5 SET I=0
SET IDX=0
+6 SET Y(0)=$PIECE($GET(^ORD(101.41,DLG,5)),"^",4)
+7 FOR
SET I=$ORDER(^ORD(101.41,DLG,50,"AC",I))
if I=""
QUIT
SET IEN=$ORDER(^(I,0))
Begin DoDot:1
+8 SET IDX=IDX+1
SET Y(IDX)=$GET(^ORD(101.41,DLG,50,IEN,0))
End DoDot:1
+9 QUIT
DEF(Y,DLG) ; Return format mapping for a dialog
+1 ; Y(n): CtrlName^DlgPtr^FmtSeq^Fmt^Omit^Lead^Trail^Mult?^chd1~chd2~...
+2 ; for testing
IF DLG="NOT IMPLEMENTED"
SET Y(0)="0^0"
QUIT
+3 SET DLG=$ORDER(^ORD(101.41,"B",DLG,0))
+4 NEW I,J,K,N,X0,X2,XW,DPTR
+5 SET Y(0)=$PIECE(^ORD(101.41,DLG,0),U,5)_U_DLG
+6 SET I=0
SET N=0
+7 FOR
SET I=$ORDER(^ORD(101.41,DLG,10,I))
if I'>0
QUIT
Begin DoDot:1
+8 SET X0=$GET(^ORD(101.41,DLG,10,I,0))
SET DPTR=$PIECE(X0,U,2)
+9 SET X2=$GET(^ORD(101.41,DLG,10,I,2))
+10 SET XW=$GET(^ORD(101.41,DLG,10,I,"W"))
+11 SET N=N+1
SET Y(N)=$PIECE(XW,U,1)_U_DPTR_U_X2
SET CHLD=""
+12 SET J=0
FOR
SET J=$ORDER(^ORD(101.41,DLG,10,"DAD",DPTR,J))
if 'J
QUIT
Begin DoDot:2
+13 SET K=0
FOR
SET K=$ORDER(^ORD(101.41,DLG,10,"DAD",DPTR,J,K))
if 'K
QUIT
Begin DoDot:3
+14 SET CHLD=CHLD_$PIECE(^ORD(101.41,DLG,10,K,0),U,2)_"~"
End DoDot:3
End DoDot:2
+15 SET $PIECE(Y(N),U,8)=CHLD
End DoDot:1
+16 QUIT
FORMID(VAL,ORIFN) ; procedure
+1 ; Returns the Dialog Form ID
+2 NEW X
+3 SET VAL=0
SET X=$PIECE(^OR(100,+ORIFN,0),U,5)
+4 if $PIECE(X,";",2)'="ORD(101.41,"
QUIT
+5 SET VAL=+$PIECE($GET(^ORD(101.41,+X,5)),U,5)
+6 ; I X S VAL=$P($G(^XTV(8989.52,+X,0)),U,2)
+7 QUIT
GET4EDIT(LST,ORIFN) ; procedure
+1 ; return responses in format that can be used by dialog
+2 NEW ILST,PRMT,INST,DLG,ORDIALOG
SET ILST=0
+3 IF '$DATA(ORIFN)
SET LST=0
QUIT
+4 SET ORIFN=+ORIFN
SET DLG=+$PIECE(^OR(100,ORIFN,0),U,5)
+5 DO GETDLG1^ORCD(DLG)
DO GETORDER^ORCD("^OR(100,"_ORIFN_",4.5)")
+6 SET PRMT=0
FOR
SET PRMT=$ORDER(ORDIALOG(PRMT))
if 'PRMT
QUIT
Begin DoDot:1
+7 SET INST=0
FOR
SET INST=$ORDER(ORDIALOG(PRMT,INST))
if 'INST
QUIT
Begin DoDot:2
+8 SET ILST=ILST+1
SET LST(ILST)="~"_PRMT_U_INST_U_$PIECE(ORDIALOG(PRMT),U,3)
+9 SET ILST=ILST+1
SET LST(ILST)="d"_ORDIALOG(PRMT,INST)
+10 ; load word processing
IF $EXTRACT(ORDIALOG(PRMT,INST))=U
Begin DoDot:3
+11 NEW I,REF
SET I=0
SET REF=ORDIALOG(PRMT,INST)
+12 FOR
SET I=$ORDER(@REF@(I))
if 'I
QUIT
SET ILST=ILST+1
SET LST(ILST)="t"_^(I,0)
End DoDot:3
+13 ; load external value
IF '$TEST
SET $PIECE(LST(ILST),U,2)=$$EXT^ORCD(PRMT,INST)
+14 IF "R"[$EXTRACT(ORDIALOG(PRMT,0))
Begin DoDot:3
+15 SET $PIECE(LST(ILST),U,2)=$$UP^XLFSTR($$FMTE^XLFDT(ORDIALOG(PRMT,INST)))
End DoDot:3
End DoDot:2
End DoDot:1
+16 QUIT
EXTDT(X) ; Return an external date time that can be interpreted by %DT
+1 IF $EXTRACT(X)="T"
QUIT "TODAY"_$EXTRACT(X,2,255)
+2 IF $EXTRACT(X)="V"
QUIT "NEXT VISIT"_$EXTRACT(X,2,255)
+3 QUIT ""
SAVE(Y,DFN,ORNP,LOC,DLG,ORWDACT,RSP) ; procedure
+1 ; Save order
+2 NEW ORDIALOG,ORL,ORVP,ORIFN,ORDUZ,ORSTS,ORDG,OREVENT,ORCAT,ORDA
+3 IF $PIECE(^ORD(101.41,+DLG,0),U)="PSO OERR"
SET ORCAT="O"
+4 IF $PIECE(^ORD(101.41,+DLG,0),U)="PSJ OR PAT OE"
SET ORCAT="I"
+5 SET ORVP=DFN_";DPT("
SET ORL(2)=LOC_";SC("
SET ORL=ORL(2)
+6 DO GETDLG^ORCD(DLG)
+7 MERGE ORDIALOG=RSP
SET ORDIALOG=DLG
+8 IF ORWDACT="N"
Begin DoDot:1
+9 DO EN^ORCSAVE
+10 SET Y=""
IF ORIFN
DO GETBYIFN^ORWORR(.Y,ORIFN)
End DoDot:1
+11 IF $PIECE(ORWDACT,U,1)="E"
Begin DoDot:1
+12 SET ORIFN=+$PIECE(ORWDACT,U,2)
DO XX^ORCSAVE
+13 SET Y=""
SET ORIFN=+$PIECE(ORWDACT,U,2)_";"_ORDA
DO GETBYIFN^ORWORR(.Y,ORIFN)
End DoDot:1
+14 QUIT
SIGN(ERRLST,DFN,ORNP,LOC,ORWSIGN) ; procedure
+1 ; Sign orders (ORIFN;ACT^RELSTS^SIGSTS^NATR)
+2 NEW ORVP,ORL,IDX,ANERROR,ERRCNT
+3 SET ORVP=DFN_";DPT("
SET ORL(2)=LOC_";SC("
SET ORL=ORL(2)
SET ERRCNT=0
+4 IF '$DATA(^XUSEC("ORES",DUZ))
SET ERRLST(1)=0_U_"Must have ORES key."
QUIT
+5 SET IDX=0
FOR
SET IDX=$ORDER(ORWSIGN(IDX))
if 'IDX
QUIT
SET X=ORWSIGN(IDX)
Begin DoDot:1
+6 ; ** change NATR when GUI changed to pass Nature in 4th piece
+7 ;$P(X,U,4)
SET ORIFN=$PIECE(X,U)
SET RELSTS=$PIECE(X,U,2)
SET SIGSTS=$PIECE(X,U,3)
SET NATR="E"
+8 IF SIGSTS=2
DO NOTIF^ORCSIGN
SET ANERROR=""
+9 IF SIGSTS'=2
DO EN^ORCSEND(ORIFN,"",SIGSTS,RELSTS,NATR,"",.ANERROR)
+10 ; don't print if an error occurred
IF $LENGTH(ANERROR)
Begin DoDot:2
+11 SET ERRCNT=ERRCNT+1
SET ERRLST(ERRCNT)=$PIECE(ORWSIGN(IDX),U)_U_ANERROR
+12 KILL ORWSIGN(IDX)
End DoDot:2
QUIT
+13 ; don't print if unreleased
IF RELSTS=0
KILL ORWSIGN(IDX)
QUIT
+14 SET ORWSIGN(IDX)=$PIECE(ORWSIGN(IDX),U)
End DoDot:1
+15 DO PRINTS^ORWD1(.ORWSIGN,LOC)
+16 QUIT
VALIDACT(VAL,ORIFN,ACTION) ;procedure
+1 ; Return 1 if action is valid for this order, otherwise 0^error
+2 SET VAL=$$VALID^ORCACT0(ORIFN,ACTION,.ERR)
+3 IF VAL=0
SET VAL=VAL_U_ERR
+4 QUIT
SAVEACT(LST,ORIFN,ACTION,REASON,DFN,ORNP,LOC) ;procedure
+1 ; Save this action for the order (it is still unsigned/unreleased)
+2 NEW ORDIALOG,ORL,ORVP,ORDUZ,ORSTS,ORDG,OREVENT,ACTDA,SIGSTS,RELSTS,ASTS
+3 SET ORVP=DFN_";DPT("
SET ORL(2)=LOC_";SC("
+4 SET SIGSTS=2
SET RELSTS=11
+5 IF '$PIECE(ORIFN,";",2)
SET $PIECE(ORIFN,";",2)=1
+6 IF (ACTION="FL")!(ACTION="UF")!(ACTION="WC")
SET SIGSTS=3
SET RELSTS=""
+7 SET ASTS=$PIECE(^OR(100,+ORIFN,8,+$PIECE(ORIFN,";",2),0),U,15)
+8 ; exit here if DELETE
IF ACTION="DC"
IF ((ASTS=10)!(ASTS=11))
Begin DoDot:1
+9 DO GETBYIFN^ORWORR(.LST,ORIFN)
+10 SET $PIECE(LST(1),U,1)="~0"
SET LST(2)="tDELETED - "_$EXTRACT(LST(2),2,245)
+11 DO CANCEL^ORCSAVE2(ORIFN)
End DoDot:1
QUIT
+12 ;
+13 ; the only valid action for ActDA>1 is deletion, so only orders
+14 ; identified by ORIFN;1 should reach this point
+15 ;
+16 IF $PIECE(ORIFN,";",2)>1
SET $ECODE=",Uorder action invalid,"
QUIT
+17 IF ACTION="FL"
SET $PIECE(^OR(100,+ORIFN,6),U,1)=1
+18 IF ACTION="UF"
SET $PIECE(^OR(100,+ORIFN,6),U,1)=0
+19 IF ACTION'="RN"
Begin DoDot:1
+20 SET ACTDA=$$ACTION^ORCSAVE(ACTION,+ORIFN,ORNP,REASON)
End DoDot:1
+21 IF ACTION="RN"
Begin DoDot:1
+22 NEW ORDA,ORDIALOG,PRMT,SAVIFN,X0
+23 SET SAVIFN=+ORIFN
SET X0=^OR(100,+ORIFN,0)
+24 ; version 3
IF $PIECE(X0,U,5)["101.41,"
Begin DoDot:2
+25 SET ORDIALOG=+$PIECE(X0,U,5)
SET ORCAT=$PIECE(^OR(100,+ORIFN,0),U,12)
+26 DO GETDLG^ORCD(ORDIALOG)
DO GETORDER^ORCD(+ORIFN)
End DoDot:2
+27 ; version 2.5 generic
IF '$TEST
Begin DoDot:2
+28 SET ORDIALOG=$ORDER(^ORD(101.41,"B","OR GXTEXT WORD PROCESSING ORDE",0))
+29 DO GETDLG^ORCD(ORDIALOG)
+30 SET PRMT=$ORDER(^ORD(101.41,"B","OR GTX WORD PROCESSING 1",0))
+31 SET ORDIALOG(PRMT,1)=$NAME(^TMP("ORWORD",$JOB,PRMT,1))
+32 MERGE ^TMP("ORWORD",$JOB,PRMT,1)=^OR(100,+ORIFN,1)
+33 SET PRMT=$ORDER(^ORD(101.41,"B","OR GTX START DATE/TIME",0))
+34 IF $PIECE(X0,U,9)
SET ORDIALOG(PRMT,1)=$PIECE(X0,U,9)
End DoDot:2
+35 DO RN^ORCSAVE
IF 'ORIFN
SET $ECODE=",UCPRS renew order,"
+36 SET ACTDA=ORDA
SET ORIFN=SAVIFN
End DoDot:1
+37 IF (ACTION="FL")!(ACTION="UF")
SET ACTDA=1
+38 DO GETBYIFN^ORWORR(.LST,+ORIFN_";"_ACTDA)
+39 SET $PIECE(LST(1),U,12)=ACTDA
+40 QUIT
