- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORCONV0 6572 printed Feb 18, 2025@23:55:23 Page 2
- 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
