ORCONV0 ; SLC/MKB - Convert protocols/menus to Dialogs cont ;9/15/97 15:41
;;3.0;ORDER ENTRY/RESULTS REPORTING;**14**;Dec 17, 1997
OR ; -- ORZ protocols
N ORGWP,ORGT,ORGX S ORGX=$G(^ORD(101,PITEM,20))
S:$O(^ORD(101,PITEM,101.0431,0))!(ORGX["^ORGWP") ORGWP=1
S:ORGX["^ORGT" ORGT=1
DLG ; -- dialog type protocols
N X,XQORM,ORPOS,XUTL,PTERM,PRMT,DA,NODE,MODE,ORDG,PKG,DTEXT,DFLT,OI,TXT,LBL,PARAM,ORSEQ
S DITEM=$$DIALOG^ORCONVRT(PITEM) G:'DITEM DLG^ORCONVRT
S PKG=+$O(^DIC(9.4,"C","OR",0))
S ORDG=$S($D(^ORD(101,"AD",+$O(^ORD(101,"B","OR GUA ACTV DISPLAY GROUP",0)),PITEM)):"ACT",$G(ORGWP)!$G(ORGT):"OTHER",1:"NURS"),ORDG=+$O(^ORD(100.98,"B",ORDG,0))_U_ORDG ; generic order
S X=^ORD(101.41,DITEM,0),DTEXT=$P(X,U,2)
S X=X_"^^D^"_+ORDG_U_$S('+$G(^ORD(101,PITEM,101.01)):2,1:0)_U_PKG_"^1^0"
S:PKG ^ORD(101.41,"APKG",PKG,DITEM)=""
D0 S ^ORD(101.41,DITEM,0)=X I $G(ORGWP)!$G(ORGT) D G D2
. S PRMT=$S($G(ORGWP):"OR GTX WORD PROCESSING 1",1:"OR GTX FREE TEXT"),PRMT=$O(^ORD(101.41,"AB",PRMT,0))
. S DA=$$NEXT^ORCONVRT(DITEM),^ORD(101.41,DITEM,10,DA,0)="1^"_PRMT_"^^Order: ^^1",^(2)=1
. S ^ORD(101.41,DITEM,10,"B",1,DA)="",^ORD(101.41,"AD",PRMT,DITEM,DA)="",^ORD(101.41,DITEM,10,"D",PRMT,DA)="",^ORD(101.41,DITEM,10,"ATXT",1,DA)=""
. I $G(ORGWP) M ^ORD(101.41,DITEM,10,DA,8)=^ORD(101,PITEM,101.0431)
S XQORM=PITEM_";ORD(101," D XREF^XQORM S ORSEQ=1
D1 S ORPOS=0 F S ORPOS=$O(^XUTL("XQORM",XQORM,ORPOS)) Q:ORPOS'>0 D
. S XUTL=$G(^XUTL("XQORM",XQORM,ORPOS,0)),PTERM=+$P(XUTL,U,2) Q:'PTERM
. I $P($G(^ORD(101,PTERM,0)),U,4)="A" S NODE=$G(^(20)) D Q
. . S X=$F(NODE,"ORTO=") Q:'X
. . S NODE=$E(NODE,X,999),X=$P(NODE,"""",4) Q:'$L(X)
. . S ORDG=+$O(^ORD(100.98,"B",X,0))
. I $P($G(^ORD(101,PTERM,0)),U,4)'="T" S ^ORD(100.99,1,101.41,PITEM,0)=PITEM_"^Incomplete dialog entry - unrecognizable item(s) in protocol." Q
. ; ** Modifying action -> Ask on Condition
. S PRMT=$$PROMPT(PTERM) G:'PRMT PROMPT^ORCONVRT
. I $O(^ORD(101.41,DITEM,10,"D",+PRMT,0)) D DUPL^ORCONVRT Q ;duplicate
. S NODE=$G(^ORD(101,PITEM,10,+XUTL,1)),MODE=$P(NODE,U,4)
. S TXT=$S($L($P(NODE,U)):$P(NODE,U)_": ",1:$P(PRMT,U,2)),ORSEQ=ORSEQ+1
. S DA=$$NEXT^ORCONVRT(DITEM,+XUTL),^ORD(101.41,DITEM,10,DA,0)=ORSEQ_U_+PRMT_U_U_TXT_U_U_(MODE["R")_U_U_(MODE["E")
. S ^ORD(101.41,DITEM,10,DA,2)=ORSEQ_"^^^"_$S(MODE["S":"",1:TXT)_"^^"_$S(MODE["\":1,1:""),^ORD(101.41,DITEM,10,"ATXT",ORSEQ,DA)=""
. S:$L($P(NODE,U,3)) ^ORD(101.41,DITEM,10,DA,1)=$P(NODE,U,3) ; help msg
. S DFLT=$P(NODE,U,2) S:$L(DFLT) ^ORD(101.41,DITEM,10,DA,7)="S Y="""_$$INTERNAL(DFLT,+PRMT)_""""
. I $O(^ORD(101,PTERM,101.0431,0)) M ^ORD(101.41,DITEM,10,DA,8)=^ORD(101,PTERM,101.0431) ; default WP text
. S ^ORD(101.41,DITEM,10,"B",ORSEQ,DA)="",^ORD(101.41,"AD",+PRMT,DITEM,DA)="",^ORD(101.41,DITEM,10,"D",+PRMT,DA)=""
D2 ; Add Start & Stop Dates
S DA=$$NEXT^ORCONVRT(DITEM),ORPOS=$O(^ORD(101.41,DITEM,10,"B","?"),-1)+1
S PRMT=$O(^ORD(101.41,"AB","OR GTX START DATE/TIME",0))
S ^ORD(101.41,DITEM,10,DA,0)=ORPOS_U_PRMT_"^^^^1^^1^RC",^(1)="Enter the date/time to begin this order",^(6)="D FTDHELP^ORCD",^(7)="S Y=""NOW"""
S ^ORD(101.41,DITEM,10,"B",ORPOS,DA)="",^ORD(101.41,DITEM,10,"D",PRMT,DA)="",^ORD(101.41,"AD",PRMT,DITEM,DA)=""
S DA=$$NEXT^ORCONVRT(DITEM),ORPOS=$O(^ORD(101.41,DITEM,10,"B","?"),-1)+1
S PRMT=$O(^ORD(101.41,"AB","OR GTX STOP DATE/TIME",0)),PARAM=$G(^ORD(100.99,1,2))
S ^ORD(101.41,DITEM,10,DA,0)=ORPOS_U_PRMT_"^^^^^^"_$S('$P(PARAM,U,9):1,1:"")_"^RC",^(1)="Enter the date/time to end this order",^(6)="D FTDHELP^ORCD"
S ^ORD(101.41,DITEM,10,DA,5)="I $$FTDCOMP^ORCD(""START DATE/TIME"",""STOP DATE/TIME"","">"") K DONE W $C(7),!,"" Cannot end before start date/time!"",!"
S ^ORD(101.41,DITEM,10,"B",ORPOS,DA)="",^ORD(101.41,DITEM,10,"D",PRMT,DA)="",^ORD(101.41,"AD",PRMT,DITEM,DA)=""
S NODE=$G(^ORD(101,PITEM,20)),X=$F(NODE,"ORGSTOP=") I X S ^ORD(101.41,DITEM,10,DA,7)="S Y="""_$$VALUE^ORCONVRT(NODE,X)_"""",$P(^(0),U,8)=1 G D3
I $P(PARAM,U,9),$P(PARAM,U,10) S ^ORD(101.41,DITEM,10,DA,7)="S Y=""T+"_$P(PARAM,U,10)_""""
D3 ; Create orderable item from Item Text
Q:$G(ORGWP) Q:$G(ORGT) ; text only orders - no OI to create
S OI=$$PTR^ORCD("OR GTX ORDERABLE ITEM"),DA=$$NEXT^ORCONVRT(DITEM)
S ^ORD(101.41,DITEM,10,DA,0)="1^"_OI_"^^Order: ^^1^^1",^(2)=1
S ^ORD(101.41,DITEM,10,"B",1,DA)="",^ORD(101.41,"AD",OI,DITEM,DA)="",^ORD(101.41,DITEM,10,"D",OI,DA)="",^ORD(101.41,DITEM,10,"ATXT",1,DA)=""
S X=$G(^ORD(101,PITEM,15)),LBL=$F(X,"ORGLABEL=")
I LBL S X=$P($E(X,LBL,$L(X)),"""",2) S:$L(X) DTEXT=X
S ^ORD(101.41,DITEM,10,DA,7)="S Y="_$$ORDITM(DTEXT,ORDG)
Q
;
PROMPT(PIFN) ; -- Returns ifn of [new] prompt in Dialog file
N DIFN,NODE,X0 S DIFN=$$DIALOG^ORCONVRT(PIFN) Q:'DIFN
S NODE=$G(^ORD(101,PIFN,101.04))
S $P(^ORD(101.41,DIFN,0),U,4)="P",^(1)=$P(NODE,U)_U_$P(NODE,U,5),X0=$G(^(0))
Q DIFN_U_$P(X0,U,2)
;
INTERNAL(VALUE,IFN) ; -- Return internal form of VALUE for prmt IFN
N DATATYPE,DOMAIN,X,Y,ROOT S Y=""
S X=$G(^ORD(101.41,IFN,1)),DATATYPE=$P(X,U),DOMAIN=$P(X,U,2)
I "DFRNW"[DATATYPE S Y=VALUE
I DATATYPE="Y" S Y=$S("YESyes"[VALUE:1,1:0)
I DATATYPE="P" D
. I +VALUE=VALUE S Y=VALUE Q
. Q:'$L(DOMAIN) S ROOT=$S(+DOMAIN:$G(^DIC(+DOMAIN,0,"GL")),1:U_DOMAIN)
. S Y=$O(@(ROOT_"""B"","""_$E(VALUE,1,30)_""",0)"))
I DATATYPE="S" D
. N I F I=1:1:$L(DOMAIN,";") S X=$P(DOMAIN,";",I) I X[(":"_VALUE) S Y=$P(X,":") Q
Q Y
;
ORDITM(X,ORDG) ; -- Find/Add orderable item X
N I,Y,D,DIC,DLAYGO,DA,DR,DIE,ID Q:'$L($G(X)) -1
F I=$L(X):-1:1 I $E(X,I)?1A S X=$E(X,1,I) Q ;Strip trailing sp, punct
S:'$G(ORDG) ORDG=$O(^ORD(100.98,"B","NURS",0))_U_"NURS"
S D="S."_$P(ORDG,U,2),Y=$O(^ORD(101.43,D,$$UP^XLFSTR(X),0)) Q:Y Y ; found
S DIC="^ORD(101.43,",DLAYGO=101.43,DIC(0)="LX" D IX^DIC S DA=+Y
I DA>0 S DIE=DIC,ID=DA_";99ORD",DR="2///^S X=ID;5////"_+ORDG D ^DIE
Q DA
;
SET ; -- extended action type protocols
N X,PKG,XQORM,ORSEQ,ORP,DA,XUTL
S DITEM=$$DIALOG^ORCONVRT(PITEM) G:'DITEM DLG^ORCONVRT
S PKG=+$O(^DIC(9.4,"C","OR",0)),X=$G(^ORD(101.41,DITEM,0))
S X=X_"^^O^^"_$S('$G(^ORD(101,PITEM,101.01)):2,1:0)_U_PKG
S ^ORD(101.41,DITEM,0)=X,^(5)="^^^^^0^1"
S:PKG ^ORD(101.41,"APKG",PKG,DITEM)=""
S XQORM=PITEM_";ORD(101," D XREF^XQORM
S ORSEQ=0 F S ORSEQ=$O(^XUTL("XQORM",XQORM,ORSEQ)) Q:ORSEQ'>0 S XUTL=$G(^(ORSEQ,0)) D
. Q:'$P(XUTL,U,2) S ORP=$$ITEM^ORCONVRT($P(XUTL,U,2)) Q:'ORP
. S DA=$$NEXT^ORCONVRT(DITEM),^ORD(101.41,DITEM,10,DA,0)=ORSEQ_U_ORP
. S ^ORD(101.41,DITEM,10,"B",ORSEQ,DA)="",^ORD(101.41,DITEM,10,"D",ORP,DA)="",^ORD(101.41,"AD",ORP,DITEM,DA)=""
Q
ORCONV0 ; SLC/MKB - Convert protocols/menus to Dialogs cont ;9/15/97 15:41
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**14**;Dec 17, 1997
OR ; -- ORZ protocols
+1 NEW ORGWP,ORGT,ORGX
SET ORGX=$GET(^ORD(101,PITEM,20))
+2 IF $ORDER(^ORD(101,PITEM,101.0431,0))!(ORGX["^ORGWP")
SET ORGWP=1
+3 IF ORGX["^ORGT"
SET ORGT=1
DLG ; -- dialog type protocols
+1 NEW X,XQORM,ORPOS,XUTL,PTERM,PRMT,DA,NODE,MODE,ORDG,PKG,DTEXT,DFLT,OI,TXT,LBL,PARAM,ORSEQ
+2 SET DITEM=$$DIALOG^ORCONVRT(PITEM)
IF 'DITEM
GOTO DLG^ORCONVRT
+3 SET PKG=+$ORDER(^DIC(9.4,"C","OR",0))
+4 ; generic order
SET ORDG=$SELECT($DATA(^ORD(101,"AD",+$ORDER(^ORD(101,"B","OR GUA ACTV DISPLAY GROUP",0)),PITEM)):"ACT",$GET(ORGWP)!$GET(ORGT):"OTHER",1:"NURS")
SET ORDG=+$ORDER(^ORD(100.98,"B",ORDG,0))_U_ORDG
+5 SET X=^ORD(101.41,DITEM,0)
SET DTEXT=$PIECE(X,U,2)
+6 SET X=X_"^^D^"_+ORDG_U_$SELECT('+$GET(^ORD(101,PITEM,101.01)):2,1:0)_U_PKG_"^1^0"
+7 IF PKG
SET ^ORD(101.41,"APKG",PKG,DITEM)=""
D0 SET ^ORD(101.41,DITEM,0)=X
IF $GET(ORGWP)!$GET(ORGT)
Begin DoDot:1
+1 SET PRMT=$SELECT($GET(ORGWP):"OR GTX WORD PROCESSING 1",1:"OR GTX FREE TEXT")
SET PRMT=$ORDER(^ORD(101.41,"AB",PRMT,0))
+2 SET DA=$$NEXT^ORCONVRT(DITEM)
SET ^ORD(101.41,DITEM,10,DA,0)="1^"_PRMT_"^^Order: ^^1"
SET ^(2)=1
+3 SET ^ORD(101.41,DITEM,10,"B",1,DA)=""
SET ^ORD(101.41,"AD",PRMT,DITEM,DA)=""
SET ^ORD(101.41,DITEM,10,"D",PRMT,DA)=""
SET ^ORD(101.41,DITEM,10,"ATXT",1,DA)=""
+4 IF $GET(ORGWP)
MERGE ^ORD(101.41,DITEM,10,DA,8)=^ORD(101,PITEM,101.0431)
End DoDot:1
GOTO D2
+5 SET XQORM=PITEM_";ORD(101,"
DO XREF^XQORM
SET ORSEQ=1
D1 SET ORPOS=0
FOR
SET ORPOS=$ORDER(^XUTL("XQORM",XQORM,ORPOS))
IF ORPOS'>0
QUIT
Begin DoDot:1
+1 SET XUTL=$GET(^XUTL("XQORM",XQORM,ORPOS,0))
SET PTERM=+$PIECE(XUTL,U,2)
IF 'PTERM
QUIT
+2 IF $PIECE($GET(^ORD(101,PTERM,0)),U,4)="A"
SET NODE=$GET(^(20))
Begin DoDot:2
+3 SET X=$FIND(NODE,"ORTO=")
IF 'X
QUIT
+4 SET NODE=$EXTRACT(NODE,X,999)
SET X=$PIECE(NODE,"""",4)
IF '$LENGTH(X)
QUIT
+5 SET ORDG=+$ORDER(^ORD(100.98,"B",X,0))
End DoDot:2
QUIT
+6 IF $PIECE($GET(^ORD(101,PTERM,0)),U,4)'="T"
SET ^ORD(100.99,1,101.41,PITEM,0)=PITEM_"^Incomplete dialog entry - unrecognizable item(s) in protocol."
QUIT
+7 ; ** Modifying action -> Ask on Condition
+8 SET PRMT=$$PROMPT(PTERM)
IF 'PRMT
GOTO PROMPT^ORCONVRT
+9 ;duplicate
IF $ORDER(^ORD(101.41,DITEM,10,"D",+PRMT,0))
DO DUPL^ORCONVRT
QUIT
+10 SET NODE=$GET(^ORD(101,PITEM,10,+XUTL,1))
SET MODE=$PIECE(NODE,U,4)
+11 SET TXT=$SELECT($LENGTH($PIECE(NODE,U)):$PIECE(NODE,U)_": ",1:$PIECE(PRMT,U,2))
SET ORSEQ=ORSEQ+1
+12 SET DA=$$NEXT^ORCONVRT(DITEM,+XUTL)
SET ^ORD(101.41,DITEM,10,DA,0)=ORSEQ_U_+PRMT_U_U_TXT_U_U_(MODE["R")_U_U_(MODE["E")
+13 SET ^ORD(101.41,DITEM,10,DA,2)=ORSEQ_"^^^"_$SELECT(MODE["S":"",1:TXT)_"^^"_$SELECT(MODE["\":1,1:"")
SET ^ORD(101.41,DITEM,10,"ATXT",ORSEQ,DA)=""
+14 ; help msg
IF $LENGTH($PIECE(NODE,U,3))
SET ^ORD(101.41,DITEM,10,DA,1)=$PIECE(NODE,U,3)
+15 SET DFLT=$PIECE(NODE,U,2)
IF $LENGTH(DFLT)
SET ^ORD(101.41,DITEM,10,DA,7)="S Y="""_$$INTERNAL(DFLT,+PRMT)_""""
+16 ; default WP text
IF $ORDER(^ORD(101,PTERM,101.0431,0))
MERGE ^ORD(101.41,DITEM,10,DA,8)=^ORD(101,PTERM,101.0431)
+17 SET ^ORD(101.41,DITEM,10,"B",ORSEQ,DA)=""
SET ^ORD(101.41,"AD",+PRMT,DITEM,DA)=""
SET ^ORD(101.41,DITEM,10,"D",+PRMT,DA)=""
End DoDot:1
D2 ; Add Start & Stop Dates
+1 SET DA=$$NEXT^ORCONVRT(DITEM)
SET ORPOS=$ORDER(^ORD(101.41,DITEM,10,"B","?"),-1)+1
+2 SET PRMT=$ORDER(^ORD(101.41,"AB","OR GTX START DATE/TIME",0))
+3 SET ^ORD(101.41,DITEM,10,DA,0)=ORPOS_U_PRMT_"^^^^1^^1^RC"
SET ^(1)="Enter the date/time to begin this order"
SET ^(6)="D FTDHELP^ORCD"
SET ^(7)="S Y=""NOW"""
+4 SET ^ORD(101.41,DITEM,10,"B",ORPOS,DA)=""
SET ^ORD(101.41,DITEM,10,"D",PRMT,DA)=""
SET ^ORD(101.41,"AD",PRMT,DITEM,DA)=""
+5 SET DA=$$NEXT^ORCONVRT(DITEM)
SET ORPOS=$ORDER(^ORD(101.41,DITEM,10,"B","?"),-1)+1
+6 SET PRMT=$ORDER(^ORD(101.41,"AB","OR GTX STOP DATE/TIME",0))
SET PARAM=$GET(^ORD(100.99,1,2))
+7 SET ^ORD(101.41,DITEM,10,DA,0)=ORPOS_U_PRMT_"^^^^^^"_$SELECT('$PIECE(PARAM,U,9):1,1:"")_"^RC"
SET ^(1)="Enter the date/time to end this order"
SET ^(6)="D FTDHELP^ORCD"
+8 SET ^ORD(101.41,DITEM,10,DA,5)="I $$FTDCOMP^ORCD(""START DATE/TIME"",""STOP DATE/TIME"","">"") K DONE W $C(7),!,"" Cannot end before start date/time!"",!"
+9 SET ^ORD(101.41,DITEM,10,"B",ORPOS,DA)=""
SET ^ORD(101.41,DITEM,10,"D",PRMT,DA)=""
SET ^ORD(101.41,"AD",PRMT,DITEM,DA)=""
+10 SET NODE=$GET(^ORD(101,PITEM,20))
SET X=$FIND(NODE,"ORGSTOP=")
IF X
SET ^ORD(101.41,DITEM,10,DA,7)="S Y="""_$$VALUE^ORCONVRT(NODE,X)_""""
SET $PIECE(^(0),U,8)=1
GOTO D3
+11 IF $PIECE(PARAM,U,9)
IF $PIECE(PARAM,U,10)
SET ^ORD(101.41,DITEM,10,DA,7)="S Y=""T+"_$PIECE(PARAM,U,10)_""""
D3 ; Create orderable item from Item Text
+1 ; text only orders - no OI to create
IF $GET(ORGWP)
QUIT
IF $GET(ORGT)
QUIT
+2 SET OI=$$PTR^ORCD("OR GTX ORDERABLE ITEM")
SET DA=$$NEXT^ORCONVRT(DITEM)
+3 SET ^ORD(101.41,DITEM,10,DA,0)="1^"_OI_"^^Order: ^^1^^1"
SET ^(2)=1
+4 SET ^ORD(101.41,DITEM,10,"B",1,DA)=""
SET ^ORD(101.41,"AD",OI,DITEM,DA)=""
SET ^ORD(101.41,DITEM,10,"D",OI,DA)=""
SET ^ORD(101.41,DITEM,10,"ATXT",1,DA)=""
+5 SET X=$GET(^ORD(101,PITEM,15))
SET LBL=$FIND(X,"ORGLABEL=")
+6 IF LBL
SET X=$PIECE($EXTRACT(X,LBL,$LENGTH(X)),"""",2)
IF $LENGTH(X)
SET DTEXT=X
+7 SET ^ORD(101.41,DITEM,10,DA,7)="S Y="_$$ORDITM(DTEXT,ORDG)
+8 QUIT
+9 ;
PROMPT(PIFN) ; -- Returns ifn of [new] prompt in Dialog file
+1 NEW DIFN,NODE,X0
SET DIFN=$$DIALOG^ORCONVRT(PIFN)
IF 'DIFN
QUIT
+2 SET NODE=$GET(^ORD(101,PIFN,101.04))
+3 SET $PIECE(^ORD(101.41,DIFN,0),U,4)="P"
SET ^(1)=$PIECE(NODE,U)_U_$PIECE(NODE,U,5)
SET X0=$GET(^(0))
+4 QUIT DIFN_U_$PIECE(X0,U,2)
+5 ;
INTERNAL(VALUE,IFN) ; -- Return internal form of VALUE for prmt IFN
+1 NEW DATATYPE,DOMAIN,X,Y,ROOT
SET Y=""
+2 SET X=$GET(^ORD(101.41,IFN,1))
SET DATATYPE=$PIECE(X,U)
SET DOMAIN=$PIECE(X,U,2)
+3 IF "DFRNW"[DATATYPE
SET Y=VALUE
+4 IF DATATYPE="Y"
SET Y=$SELECT("YESyes"[VALUE:1,1:0)
+5 IF DATATYPE="P"
Begin DoDot:1
+6 IF +VALUE=VALUE
SET Y=VALUE
QUIT
+7 IF '$LENGTH(DOMAIN)
QUIT
SET ROOT=$SELECT(+DOMAIN:$GET(^DIC(+DOMAIN,0,"GL")),1:U_DOMAIN)
+8 SET Y=$ORDER(@(ROOT_"""B"","""_$EXTRACT(VALUE,1,30)_""",0)"))
End DoDot:1
+9 IF DATATYPE="S"
Begin DoDot:1
+10 NEW I
FOR I=1:1:$LENGTH(DOMAIN,";")
SET X=$PIECE(DOMAIN,";",I)
IF X[(":"_VALUE)
SET Y=$PIECE(X,":")
QUIT
End DoDot:1
+11 QUIT Y
+12 ;
ORDITM(X,ORDG) ; -- Find/Add orderable item X
+1 NEW I,Y,D,DIC,DLAYGO,DA,DR,DIE,ID
IF '$LENGTH($GET(X))
QUIT -1
+2 ;Strip trailing sp, punct
FOR I=$LENGTH(X):-1:1
IF $EXTRACT(X,I)?1A
SET X=$EXTRACT(X,1,I)
QUIT
+3 IF '$GET(ORDG)
SET ORDG=$ORDER(^ORD(100.98,"B","NURS",0))_U_"NURS"
+4 ; found
SET D="S."_$PIECE(ORDG,U,2)
SET Y=$ORDER(^ORD(101.43,D,$$UP^XLFSTR(X),0))
IF Y
QUIT Y
+5 SET DIC="^ORD(101.43,"
SET DLAYGO=101.43
SET DIC(0)="LX"
DO IX^DIC
SET DA=+Y
+6 IF DA>0
SET DIE=DIC
SET ID=DA_";99ORD"
SET DR="2///^S X=ID;5////"_+ORDG
DO ^DIE
+7 QUIT DA
+8 ;
SET ; -- extended action type protocols
+1 NEW X,PKG,XQORM,ORSEQ,ORP,DA,XUTL
+2 SET DITEM=$$DIALOG^ORCONVRT(PITEM)
IF 'DITEM
GOTO DLG^ORCONVRT
+3 SET PKG=+$ORDER(^DIC(9.4,"C","OR",0))
SET X=$GET(^ORD(101.41,DITEM,0))
+4 SET X=X_"^^O^^"_$SELECT('$GET(^ORD(101,PITEM,101.01)):2,1:0)_U_PKG
+5 SET ^ORD(101.41,DITEM,0)=X
SET ^(5)="^^^^^0^1"
+6 IF PKG
SET ^ORD(101.41,"APKG",PKG,DITEM)=""
+7 SET XQORM=PITEM_";ORD(101,"
DO XREF^XQORM
+8 SET ORSEQ=0
FOR
SET ORSEQ=$ORDER(^XUTL("XQORM",XQORM,ORSEQ))
IF ORSEQ'>0
QUIT
SET XUTL=$GET(^(ORSEQ,0))
Begin DoDot:1
+9 IF '$PIECE(XUTL,U,2)
QUIT
SET ORP=$$ITEM^ORCONVRT($PIECE(XUTL,U,2))
IF 'ORP
QUIT
+10 SET DA=$$NEXT^ORCONVRT(DITEM)
SET ^ORD(101.41,DITEM,10,DA,0)=ORSEQ_U_ORP
+11 SET ^ORD(101.41,DITEM,10,"B",ORSEQ,DA)=""
SET ^ORD(101.41,DITEM,10,"D",ORP,DA)=""
SET ^ORD(101.41,"AD",ORP,DITEM,DA)=""
End DoDot:1
+12 QUIT
