ORWLRAP1 ;DSS/TFF - LAB ANATOMIC PATHOLOGY CONFIGURATION SUPPORT ;Feb 16, 2024@14:39
;;3.0;ORDER ENTRY/RESULTS REPORTING;**539,569,588,601**;Dec 17, 1997;Build 1
;
;
; Reference to COLL^LR7OR3 in ICR #2428
; Reference to OK4CPRS^LRAPDLG in ICR #7339
; Reference to ^LAB(62, in ICR #2389
;
Q
;
; ORDER ELEMENT Configuration handled after the order element population
; PAGE Configuration
; SPECIMEN LIST Is populated or a lookup is used independently of this RPC
; SPECIMEN Configuration happens when the user selects a specimen on the dialog
;
GETIEN(IDX) ; Get the 101.45 IEN from the orderable item IEN
Q +$O(^ORD(101.45,"C",IDX,0))
;
CONFIG(RET,TYP,IEN) ; RPC: ORWLRAP1 CONFIG
; *This configures the Delphi forms for CPRS aside from the original elements found
; in the Lab order dialog.
;
; TYP = O - ORDER ELEMENTS
; OCM - ORDER CHANGE MESSAGE
; P - PAGES
; PG;# - PAGE CONFIGURATION
; SP;# - SPECIMEN
;
N OD,PG,L,W,WL,SP,SPB,BLK,POS,DES,CT
S IEN=$$GETIEN(+$G(IEN)),RET=$NA(^TMP($J,"CONFIG ORWLRAP1")) K @RET S @RET@(0)=0
Q:'IEN!($G(TYP)="")
I '$D(^ORD(101.45,IEN)) D DEFAULT(TYP) Q
; *** ORDER ELEMENTS
; O^ID^HIDE(1,0)^REQUIRED(1,0)^DEFAULT_VALUE
I TYP="O" D D END Q
. S OD=0 F S OD=$O(^ORD(101.45,IEN,1,OD)) Q:'OD D
. . S @RET@("O",OD)="O^"_$G(^ORD(101.45,IEN,1,OD,0))
; *** ORDER CHANGE MESSAGE
I TYP="OCM" S @RET@(0)=$G(^ORD(101.45,IEN,4)) Q
; *** PAGES
; P^NUMBER^NAME^RESPONSE_ID
I TYP="P"!(TYP?1"PG;".N) D D END Q
. S PG=0 F S PG=$O(^ORD(101.45,IEN,2,PG)) Q:'PG D
. . Q:TYP?1"PG;".N&(PG'=$P(TYP,";",2))
. . S L=$G(^ORD(101.45,IEN,2,PG,0))
. . Q:$P(L,U,3) ; *** HIDE PAGE
. . I TYP="P" S @RET@("P",PG)="P^"_PG_U_$$NRQ($P(L,U,4),$P(L,U,2))_U_$P(L,U,5) Q
. . ; *** PAGE WP BUILDER BLOCK
. . ; PWB^PAGE^ID^TITLE^LIST(1,0)^DEFAULT_VALUE
. . ; PWV^PAGE^ID^VAL;D-CODE;#|VAL;E;#| (D(ate),E(dit))
. . ; PWW^PAGE^TITLE
. . I $P($G(^ORD(101.45,IEN,2,PG,1,0)),U,4) D
. . . S W=0 F S W=$O(^ORD(101.45,IEN,2,PG,1,W)) Q:'W D
. . . . S WL=$G(^ORD(101.45,IEN,2,PG,1,W,0))
. . . . S @RET@("P",PG,W)="PWB^"_PG_U_W_U_$$NRQ($P(WL,U,2),$P(WL,U))_U_$P(WL,U,3)_U_$P(WL,U,4)
. . . . S @RET@("P",PG,W,"V")="PWV^"_PG_U_W_U_$$VWL(2,PG,W)
. . S @RET@("P",PG)="PWW^"_PG_U_$P($G(^ORD(101.45,IEN,2,PG,0)),U,6)
; *** SPECIMEN
; SPH^SP^HIDE_FROM_DESCRIPTION^POSITION^COLLECTION_SAMPLE_HIDE(1,0)^COLLECTION_SAMPLE_DEFAULT
; SPB^SP^ID^TITLE^HIDE^REQUIRED^DEFAULT_VALUE^POSITION
; SPV^SP^ID^VAL|VAL(;CODE;CD_VALUE)
I TYP?1"SP;".N S SP=+$P(TYP,";",2) D D END Q
. S @RET@("S",0)="SPH^"_SP_U_$P($G(^ORD(101.45,IEN,3,SP,0)),U,2)_U_+$P($G(^ORD(101.45,IEN,3,SP,0)),U,3)_U_$P($G(^ORD(101.45,IEN,3,SP,2)),U,1,2)
. Q:'$D(^ORD(101.45,IEN,3,SP))
. S (BLK,SPB)=0 F S SPB=$O(^ORD(101.45,IEN,3,SP,1,SPB)),BLK=BLK+1 Q:'SPB!(BLK>4) D
. . S @RET@("S",SPB)="SPB^"_SP_U_SPB_U_$G(^ORD(101.45,IEN,3,SP,1,SPB,0))
. . S POS(+$P(@RET@("S",SPB),U,8),SPB)=""
. . S @RET@("S",SPB,"V")="SPV^"_SP_U_SPB_U_$$VWL(3,SP,SPB)
. ; *** Fix Specimen Description Positioning
. S DES(+$P(@RET@("S",0),U,4))=""
. S CT="" F S CT=$O(POS(CT)) Q:CT="" D
. . S SPB=0 F S SPB=$O(POS(CT,SPB)) Q:'SPB D
. . . I $D(DES(CT)) S DES($O(DES(""),-1)+1)="",$P(@RET@("S",SPB),U,8)=$O(DES(""),-1) Q
. . . S DES(CT)=""
Q
;
DEFAULT(TYP) ; Set Default Configuration
; *RET
; *** ORDER ELEMENTS
; O^ID^HIDE(1,0)^REQUIRED(1,0)^DEFAULT_VALUE
I TYP="O" D D END Q
. S @RET@("O",1)="O^OPURG^^1"
. S @RET@("O",2)="O^OPCDT^^1"
. S @RET@("O",3)="O^OPCTY^^^WC"
; *** PAGES
; P^NUMBER^NAME^RESPONSE_ID
I TYP="P" D D END Q
. S @RET@("P",1)="P^1^*Clinical History^CLINHX"
. S @RET@("P",2)="P^2^Pre-Operative Diagnosis^PREOPDX"
. S @RET@("P",3)="P^3^Operative Findings^OPFIND"
. S @RET@("P",4)="P^4^Post-Operative Findings^POSTOPDX"
I TYP?1"PG;".N D D END Q
. S @RET@("P",$P(TYP,";",2))="PWW^"_$P(TYP,";",2)
; *** SPECIMEN
; SPH^SP^HIDE_FROM_DESCRIPTION^POSITION^COLLECTION_SAMPLE_HIDE(1,0)^COLLECTION_SAMPLE_DEFAULT
I TYP?1"SP;".N D D END
. S @RET@("S",0)="SPH^"_$P(TYP,";",2)_"^^0^^"_$$FIND1^DIC(62,,"X","AP SPECIMEN")
Q
;
SPEC(RET,IEN) ; RPC: ORWLRAP1 SPEC
; *This returns the default specimen list.
;
; RETURN
; 0 (1,0)ALLOW_OTHER^(1,0)RESTRICT_MULTIPLE
; # IEN^SPECIMEN_NAME
;
N C,SP
S IEN=$$GETIEN(+$G(IEN)),RET=$NA(^TMP($J,"SPEC ORWLRAP1")) K @RET S @RET@(0)=0
Q:'IEN Q:'$D(^ORD(101.45,IEN))
S @RET@(0)=+$P($G(^ORD(101.45,IEN,0)),U,2)_U_+$P($G(^ORD(101.45,IEN,0)),U,3) D SPEC1
Q:'$P($G(^ORD(101.45,IEN,3,0)),U,4)
S C=$O(@RET@(""),-1)+1
S SP="" F S SP=$O(^ORD(101.45,IEN,3,"S",SP)) Q:SP="" D
. S @RET@(C)=$O(^ORD(101.45,IEN,3,"S",SP,""))_U_SP,C=C+1
Q
;
SPEC1() ; Lab list of specimens for this test
N OROUT,IDX
Q:'IEN
S IDX=+$P($G(^ORD(101.45,IEN,0)),U,4)
Q:'IDX
D COLL^LR7OR3(+$$GET1^DIQ(101.43,IDX,2),.OROUT) Q:'$G(OROUT("Specimens"))
S CT=0 F S CT=$O(OROUT("Specimens",CT)) Q:'CT D
. S @RET@(CT)=OROUT("Specimens",CT)
Q
;
; SUPPORTING APIs ------------------------------------------------------------
;
NRQ(RQ,NM) ; Add * to name if required
Q:RQ "*"_NM
Q NM
;
VWL(ND0,ND1,IENS) ; Add value list as pipe delimited string
N V,STR
S V="" F S V=$O(^ORD(101.45,IEN,ND0,ND1,1,IENS,1,"B",V)) Q:V="" D
. S STR=$S($D(STR):STR_"|"_$$EXT(1),1:$$EXT(1))_$S(ND0=2:";"_$$EXT(2)_"-"_$$EXT(4)_";"_$$EXT(3),1:";"_$$EXT(2))
Q $G(STR)
;
EXT(PC) ; Extend Value
Q:'$G(PC) ""
N VI S VI=$O(^ORD(101.45,IEN,ND0,ND1,1,IENS,1,"B",V,""))
Q $P($G(^ORD(101.45,IEN,ND0,ND1,1,IENS,1,+VI,0)),U,PC)
;
END ; Clean Up
I $O(@RET@(""),-1)?.A K @RET@(0) Q
K:$O(@RET@(""),-1) @RET@(0)
Q
;
APOITEMS(Y,QOCALL,SHOWALL,CODE,NATFLAG,ACCESS) ; Subset of AP orderable items
; Y(n)=IEN^.01 Name^.01 Name -or- IEN^Synonym <.01 Name>^.01 Name
; QOCALL = Allow quick orders
; SHOWALL = Show inactive entries
; CODE: 0 = List only entries already in File 101.45
; 1 = List only entries not already in File 101.45
; NATFLAG = Add National Standard flag as piece 4 of the data
; ACCESS - List of allowed display groups
;
N I,IEN,X,CURTM,FROM,XREF,LABIEN,INACTIVE,CHKACCESS,LRCODE,ORTESTIEN,ORLABOK
N ORLRFILTER
S QOCALL=+$G(QOCALL),CODE=+$G(CODE),NATFLAG=+$G(NATFLAG),SHOWALL=+$G(SHOWALL)
S ACCESS=$G(ACCESS),CHKACCESS=($L(ACCESS)>1)
S I=0,FROM="",XREF="S.AP",CURTM=$$NOW^XLFDT
S ORLRFILTER=+$$GET^XPAR("SYS","OR LR ORDERABLE ITEM FILTERING",1,"I")
F S FROM=$O(^ORD(101.43,XREF,FROM)) Q:FROM="" D
. S IEN="" F S IEN=$O(^ORD(101.43,XREF,FROM,IEN)) Q:'IEN D
. . I '$$OK4CPRS(IEN) Q
. . S LABIEN=+$O(^ORD(101.45,"C",IEN,0))
. . S INACTIVE=$S(LABIEN:+$P($G(^ORD(101.45,LABIEN,0)),U,6),1:0)
. . I CODE=0,'LABIEN Q
. . I CODE=1,LABIEN Q
. . I 'SHOWALL,INACTIVE Q
. . I CHKACCESS D I ACCESS'[(U_LRCODE_U) Q
. . . S LRCODE=$P($G(^ORD(101.43,IEN,"LR")),U,6)
. . . I LRCODE="" S LRCODE="CH"
. . S X=$G(^ORD(101.43,XREF,FROM,IEN))
. . I +$P(X,U,3),$P(X,U,3)<CURTM Q
. . I 'QOCALL,$P(X,U,5) Q
. . I ORLRFILTER,'$$CHKLABDIV^ORWDX2(IEN,XREF) Q
. . S I=I+1
. . I 'X S Y(I)=IEN_U_$P(X,U,2)_U_$P(X,U,2)
. . E S Y(I)=IEN_U_$P(X,U,2)_$C(9)_"<"_$P(X,U,4)_">"_U_$P(X,U,4)
. . I NATFLAG S $P(Y(I),U,4)=$S(LABIEN:+$P($G(^ORD(101.45,LABIEN,0)),U,5),1:0)
. . I SHOWALL,INACTIVE S $P(Y(I),U,2)=$P(Y(I),U,2)_" <Inactive>"
Q
;
OK4CPRS(ORDITEM,QUICK) ; Determines if an orderable item is allowed for AP Dialogs
; Also used as a screen by the LR OTHER LAB AP TESTS order dialog
N LABTEST,OK,LABIEN,NAME,X
S OK=0
S LABTEST=$P($G(^ORD(101.43,ORDITEM,0)),U,2)
S LABTEST=$S($P(LABTEST,";",2)="99LRT":+LABTEST,1:0)
I 'LABTEST Q 0
I $$OK4CPRS^LRAPDLG(LABTEST) S OK=1
I OK,$G(QUICK) D
. S OK=0
. S LABIEN=+$O(^ORD(101.45,"C",ORDITEM,0)) I 'LABIEN Q
. I +$P($G(^ORD(101.45,LABIEN,0)),U,6) Q
. S NAME=$P($G(^ORD(101.43,ORDITEM,0)),U) I NAME="" Q
. S X=$G(^ORD(101.43,"S.AP",NAME,ORDITEM)) I X="" Q
. I +$P(X,U,3),$P(X,U,3)<$$NOW^XLFDT Q
. S OK=1
Q OK
;
APORDITM(Y,QOCALL,ACCESS) ; Subset of AP orderable items
D APOITEMS(.Y,$G(QOCALL),,,,$G(ACCESS))
Q
;
APDLGS ; Update AP Order Dialogs - Entry point for Option ORCM UPDATE AP DIALOGS
N RESPONSE,ACTION,DLGIEN,EDITIEN,OIIEN,NAME,X0,I,NATSTAND,ORAPDLGEDIT
S ORAPDLGEDIT=1 ; Disables NAME field override
F D Q:ACTION=""
. W !!,"Update Anatomic Pathology Order Dialogs",!
. S RESPONSE=$$GETAPIENS
. S ACTION=$P(RESPONSE,U) Q:(ACTION="")!(ACTION="R")
. S DLGIEN=$P(RESPONSE,U,2),OIIEN=$P(RESPONSE,U,3),NATSTAND=$P(RESPONSE,U,4)
. S EDITIEN=0
. I ACTION="E" S EDITIEN=DLGIEN
. I "^C^N^"[(U_ACTION_U) D Q:ACTION="R"
. . N FDA,MSG,IEN
. . I 'OIIEN S ACTION="R" Q
. . S NAME=$P($G(^ORD(101.43,OIIEN,0)),U)
. . I NAME="" W !,"Orderable Item not found!",! S ACTION="R" Q
. . S FDA(101.45,"+1,",.01)=NAME,FDA(101.45,"+1,",.04)=OIIEN
. . S FDA(101.45,"+1,",.06)=1 ; new entry starts as inactive
. . I ACTION="C" D
. . . S X0=$G(^ORD(101.45,DLGIEN,0))
. . . S FDA(101.45,"+1,",.02)=$P(X0,U,2)
. . . S FDA(101.45,"+1,",.03)=$P(X0,U,3)
. . D UPDATE^DIE("","FDA","IEN","MSG")
. . I ($D(MSG)>0)!('$G(IEN(1))) W !,"Error creating new entry. Please try again later." S ACTION="R" Q
. . S EDITIEN=IEN(1)
. . I ACTION="C" D
. . . F I=1:1:4 I $D(^ORD(101.45,DLGIEN,I)) M ^ORD(101.45,EDITIEN,I)=^ORD(101.45,DLGIEN,I)
. I EDITIEN D
. . N DA,DIE,DR
. . S DIE="^ORD(101.45,",DA=+EDITIEN
. . I NATSTAND S DR="[OR AP DIALOG ACTIVATE ONLY]"
. . E S DR="[OR AP DIALOG EDIT TEMPLATE]"
. . D ^DIE
Q
;
GETAPIENS() ;
N IDX,OILIST,ITEM,FLAG,HASFLAGS,CANEDIT,MAX,UMAX,ACTION,ACTIONS,INDEX
N EDITIDX,TXT,NEWIDX,EDITIEN,NEWIEN,EDITNAME,NEWNAME,MSG,NATFLAG
N DA,DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT,DONE,UNASSIGNED,CANCOPY,ACTCOUNT
D APOITEMS(.UNASSIGNED,0,1,1) S UMAX=+$O(UNASSIGNED(9999999),-1),CANCOPY=(UMAX>0)
D APOITEMS(.OILIST,0,1,0,1) S MAX=+$O(OILIST(9999999),-1),CANEDIT=(MAX>0)
S (HASFLAGS,EDITIDX,NEWIDX)=0,(ACTION,ACTIONS)=""
S IDX=0 F S IDX=$O(OILIST(IDX)) Q:('IDX)!HASFLAGS D
. I $P(OILIST(IDX),U,4)=1 S HASFLAGS=1
W !,"Before you can copy existing anatomic pathology order dialogs,"
W !,"or create new order dialogs, you must work with your laboratory"
W !,"application coordinator to create new, active anatomic pathology"
W !,"tests in the LABORATORY TEST File (#60) that are mapped to a"
W !,"CPRS SCREEN.",!
I CANCOPY D
. D ADDACTION("N")
. I MAX D ADDACTION("C")
I CANEDIT D ADDACTION("E")
I ACTIONS="" Q ""
S ACTCOUNT=$L(ACTIONS,";")
I ACTCOUNT=1 S ACTION=$E(ACTIONS,1)
E D
. S TXT="",INDEX=0,DIR(0)="SOB^"_ACTIONS
. F IDX=1:1:ACTCOUNT S ACTION=$P($P(ACTIONS,";",IDX),":") D
. . D ADD(.TXT,$$GETATXT(ACTION),$S(IDX<ACTCOUNT:", ",1:" or "))
. . D ADDDESC(ACTION)
. S DIR("A")=TXT,DIR("?")=" "
. D ^DIR S ACTION=$S($D(DIRUT):"",1:$G(Y))
I ACTION="" Q ""
; Get OILIST array index (in EDITIDX) for Copy or Edit
I "^C^E^"[(U_ACTION_U) D
. W !!,"Existing Anatomic Pathology Order Dialogs:",!!
. S IDX=0 F S IDX=$O(OILIST(IDX)) Q:'IDX D
. . S ITEM=OILIST(IDX),FLAG=$S($P(ITEM,U,4)=1:"*",1:" ")
. . W ?1,IDX,?5,FLAG_$P(ITEM,U,2),!
. I HASFLAGS W !,"* Indicates a National Standard.",!
. K DA,DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
. S DIR(0)="NOA^1:"_MAX_":0"
. S DIR("A")="Select Order Dialog to "_$$GETATXT(ACTION)_" (1-"_MAX_"): "
. D ^DIR I $D(DIRUT) S ACTION="" Q
. W !," ",$P($G(OILIST(+$G(Y))),U,2),!
. S EDITIDX=+$G(Y) I EDITIDX=0 S ACTION="R"
; Get UNASSIGNED array Index (in NEWIDX) for New or Copy
I "^C^N^"[(U_ACTION_U) D
. W !!,"Anatomic Pathology Orderable Items not assigned to an Order Dialog:",!!
. S IDX=0 F S IDX=$O(UNASSIGNED(IDX)) Q:'IDX D
. . W ?1,IDX,?5,$P(UNASSIGNED(IDX),U,2),!
. K DA,DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
. S DIR(0)="NOA^1:"_UMAX_":0"
. I ACTION="N" S TXT="New"
. E S TXT="Copied"
. S DIR("A")="Attach "_TXT_" Order Dialog to which Orderable Item? (1-"_UMAX_"): "
. D ^DIR I $D(DIRUT) S ACTION="" Q
. W !," ",$P($G(UNASSIGNED(+$G(Y))),U,2),!
. S NEWIDX=+$G(Y) I NEWIDX=0 S ACTION="R"
Q:(ACTION="")!(ACTION="R") ACTION
S EDITIEN=$P($G(OILIST(EDITIDX)),U) I EDITIEN S EDITIEN=$O(^ORD(101.45,"C",EDITIEN,0))
S EDITNAME=$P($G(OILIST(EDITIDX)),U,2)_" order dialog"
S NEWIEN=$P($G(UNASSIGNED(NEWIDX)),U)
S NEWNAME=$P($G(UNASSIGNED(NEWIDX)),U,2)_" orderable item"
K DA,DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
W !
S DIR(0)="YA",DIR("B")="NO",TXT=""
I ACTION="N" S TXT="Create new order dialog and link it to "_NEWNAME
I ACTION="C" S TXT="Copy "_EDITNAME_" and link it to "_NEWNAME
I ACTION="E" S TXT="Edit "_EDITNAME
I TXT'="" D
. S TXT=TXT_"? (Yes or No): "
. D WRAP^ORUTL(TXT,"DIR(""A"")",1,0,2,0,70)
. S IDX=$O(DIR("A",99999),-1) S DIR("A")=DIR("A",IDX) K DIR("A",IDX)
. D ^DIR I $D(DIRUT) S ACTION="" Q
. I $G(Y)'=1 S ACTION="R"
S NATFLAG="" I ACTION="E",+EDITIEN,$P($G(^ORD(101.45,EDITIEN,0)),U,5) S NATFLAG=1
Q ACTION_U_EDITIEN_U_NEWIEN_U_NATFLAG
;
ADDACTION(ACTION) ; Add Action Text to TEXT
N ATXT S ATXT=ACTION_":"_$$GETATXT(ACTION)
D ADD(.ACTIONS,ATXT,";")
Q
;
ADD(TEXT,TEXT2,PREFIX) ; Add TEXT2 to TEXT, insert PREFIX between the two if TEXT '= ""
N RESULT
S RESULT=TEXT
I TEXT'="" S RESULT=RESULT_PREFIX
S RESULT=RESULT_TEXT2
S TEXT=RESULT
Q
;
GETATXT(ACTION) ; Get Action Text
I ACTION="N" Q "New"
I ACTION="C" Q "Copy"
I ACTION="E" Q "Edit"
Q "*** ERROR: INVALID ACTION """_ACTION_""""
;
ADDQ(TEXT) ; Add TEXT to DIR("?",INDEX) or RESULT
S INDEX=INDEX+1
S DIR("?",INDEX)=TEXT
Q
;
ADDDESC(ACTION) ; Get action description
I ACTION="N" D Q
. D ADDQ("(N)ew will create a new order dialog, link it to an existing,")
. D ADDQ(" unassigned, anatomic pathology orderable item, and allow")
. D ADDQ(" you to edit the new order dialog.")
. D ADDQ(" ")
I ACTION="C" D Q
. D ADDQ("(C)opy will copy an existing order dialog to a new order dialog,")
. D ADDQ(" link that dialog to an existing, unassigned, anatomic pathology")
. D ADDQ(" orderable item, and allow you to edit the copied order dialog.")
. D ADDQ(" ")
I ACTION="E" D Q
. N ETXT
. S ETXT="(E)dit allows you to edit an existing order dialog."
. I HASFLAGS S ETXT=ETXT_" National"
. D ADDQ(ETXT)
. I HASFLAGS D ADDQ(" Standard dialogs may only be activated/inactivated.")
. D ADDQ(" ")
D ADDQ($$GETATXT(ACTION))
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORWLRAP1 14521 printed Oct 16, 2024@18:37:13 Page 2
ORWLRAP1 ;DSS/TFF - LAB ANATOMIC PATHOLOGY CONFIGURATION SUPPORT ;Feb 16, 2024@14:39
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**539,569,588,601**;Dec 17, 1997;Build 1
+2 ;
+3 ;
+4 ; Reference to COLL^LR7OR3 in ICR #2428
+5 ; Reference to OK4CPRS^LRAPDLG in ICR #7339
+6 ; Reference to ^LAB(62, in ICR #2389
+7 ;
+8 QUIT
+9 ;
+10 ; ORDER ELEMENT Configuration handled after the order element population
+11 ; PAGE Configuration
+12 ; SPECIMEN LIST Is populated or a lookup is used independently of this RPC
+13 ; SPECIMEN Configuration happens when the user selects a specimen on the dialog
+14 ;
GETIEN(IDX) ; Get the 101.45 IEN from the orderable item IEN
+1 QUIT +$ORDER(^ORD(101.45,"C",IDX,0))
+2 ;
CONFIG(RET,TYP,IEN) ; RPC: ORWLRAP1 CONFIG
+1 ; *This configures the Delphi forms for CPRS aside from the original elements found
+2 ; in the Lab order dialog.
+3 ;
+4 ; TYP = O - ORDER ELEMENTS
+5 ; OCM - ORDER CHANGE MESSAGE
+6 ; P - PAGES
+7 ; PG;# - PAGE CONFIGURATION
+8 ; SP;# - SPECIMEN
+9 ;
+10 NEW OD,PG,L,W,WL,SP,SPB,BLK,POS,DES,CT
+11 SET IEN=$$GETIEN(+$GET(IEN))
SET RET=$NAME(^TMP($JOB,"CONFIG ORWLRAP1"))
KILL @RET
SET @RET@(0)=0
+12 if 'IEN!($GET(TYP)="")
QUIT
+13 IF '$DATA(^ORD(101.45,IEN))
DO DEFAULT(TYP)
QUIT
+14 ; *** ORDER ELEMENTS
+15 ; O^ID^HIDE(1,0)^REQUIRED(1,0)^DEFAULT_VALUE
+16 IF TYP="O"
Begin DoDot:1
+17 SET OD=0
FOR
SET OD=$ORDER(^ORD(101.45,IEN,1,OD))
if 'OD
QUIT
Begin DoDot:2
+18 SET @RET@("O",OD)="O^"_$GET(^ORD(101.45,IEN,1,OD,0))
End DoDot:2
End DoDot:1
DO END
QUIT
+19 ; *** ORDER CHANGE MESSAGE
+20 IF TYP="OCM"
SET @RET@(0)=$GET(^ORD(101.45,IEN,4))
QUIT
+21 ; *** PAGES
+22 ; P^NUMBER^NAME^RESPONSE_ID
+23 IF TYP="P"!(TYP?1"PG;".N)
Begin DoDot:1
+24 SET PG=0
FOR
SET PG=$ORDER(^ORD(101.45,IEN,2,PG))
if 'PG
QUIT
Begin DoDot:2
+25 if TYP?1"PG;".N&(PG'=$PIECE(TYP,";",2))
QUIT
+26 SET L=$GET(^ORD(101.45,IEN,2,PG,0))
+27 ; *** HIDE PAGE
if $PIECE(L,U,3)
QUIT
+28 IF TYP="P"
SET @RET@("P",PG)="P^"_PG_U_$$NRQ($PIECE(L,U,4),$PIECE(L,U,2))_U_$PIECE(L,U,5)
QUIT
+29 ; *** PAGE WP BUILDER BLOCK
+30 ; PWB^PAGE^ID^TITLE^LIST(1,0)^DEFAULT_VALUE
+31 ; PWV^PAGE^ID^VAL;D-CODE;#|VAL;E;#| (D(ate),E(dit))
+32 ; PWW^PAGE^TITLE
+33 IF $PIECE($GET(^ORD(101.45,IEN,2,PG,1,0)),U,4)
Begin DoDot:3
+34 SET W=0
FOR
SET W=$ORDER(^ORD(101.45,IEN,2,PG,1,W))
if 'W
QUIT
Begin DoDot:4
+35 SET WL=$GET(^ORD(101.45,IEN,2,PG,1,W,0))
+36 SET @RET@("P",PG,W)="PWB^"_PG_U_W_U_$$NRQ($PIECE(WL,U,2),$PIECE(WL,U))_U_$PIECE(WL,U,3)_U_$PIECE(WL,U,4)
+37 SET @RET@("P",PG,W,"V")="PWV^"_PG_U_W_U_$$VWL(2,PG,W)
End DoDot:4
End DoDot:3
+38 SET @RET@("P",PG)="PWW^"_PG_U_$PIECE($GET(^ORD(101.45,IEN,2,PG,0)),U,6)
End DoDot:2
End DoDot:1
DO END
QUIT
+39 ; *** SPECIMEN
+40 ; SPH^SP^HIDE_FROM_DESCRIPTION^POSITION^COLLECTION_SAMPLE_HIDE(1,0)^COLLECTION_SAMPLE_DEFAULT
+41 ; SPB^SP^ID^TITLE^HIDE^REQUIRED^DEFAULT_VALUE^POSITION
+42 ; SPV^SP^ID^VAL|VAL(;CODE;CD_VALUE)
+43 IF TYP?1"SP;".N
SET SP=+$PIECE(TYP,";",2)
Begin DoDot:1
+44 SET @RET@("S",0)="SPH^"_SP_U_$PIECE($GET(^ORD(101.45,IEN,3,SP,0)),U,2)_U_+$PIECE($GET(^ORD(101.45,IEN,3,SP,0)),U,3)_U_$PIECE($GET(^ORD(101.45,IEN,3,SP,2)),U,1,2)
+45 if '$DATA(^ORD(101.45,IEN,3,SP))
QUIT
+46 SET (BLK,SPB)=0
FOR
SET SPB=$ORDER(^ORD(101.45,IEN,3,SP,1,SPB))
SET BLK=BLK+1
if 'SPB!(BLK>4)
QUIT
Begin DoDot:2
+47 SET @RET@("S",SPB)="SPB^"_SP_U_SPB_U_$GET(^ORD(101.45,IEN,3,SP,1,SPB,0))
+48 SET POS(+$PIECE(@RET@("S",SPB),U,8),SPB)=""
+49 SET @RET@("S",SPB,"V")="SPV^"_SP_U_SPB_U_$$VWL(3,SP,SPB)
End DoDot:2
+50 ; *** Fix Specimen Description Positioning
+51 SET DES(+$PIECE(@RET@("S",0),U,4))=""
+52 SET CT=""
FOR
SET CT=$ORDER(POS(CT))
if CT=""
QUIT
Begin DoDot:2
+53 SET SPB=0
FOR
SET SPB=$ORDER(POS(CT,SPB))
if 'SPB
QUIT
Begin DoDot:3
+54 IF $DATA(DES(CT))
SET DES($ORDER(DES(""),-1)+1)=""
SET $PIECE(@RET@("S",SPB),U,8)=$ORDER(DES(""),-1)
QUIT
+55 SET DES(CT)=""
End DoDot:3
End DoDot:2
End DoDot:1
DO END
QUIT
+56 QUIT
+57 ;
DEFAULT(TYP) ; Set Default Configuration
+1 ; *RET
+2 ; *** ORDER ELEMENTS
+3 ; O^ID^HIDE(1,0)^REQUIRED(1,0)^DEFAULT_VALUE
+4 IF TYP="O"
Begin DoDot:1
+5 SET @RET@("O",1)="O^OPURG^^1"
+6 SET @RET@("O",2)="O^OPCDT^^1"
+7 SET @RET@("O",3)="O^OPCTY^^^WC"
End DoDot:1
DO END
QUIT
+8 ; *** PAGES
+9 ; P^NUMBER^NAME^RESPONSE_ID
+10 IF TYP="P"
Begin DoDot:1
+11 SET @RET@("P",1)="P^1^*Clinical History^CLINHX"
+12 SET @RET@("P",2)="P^2^Pre-Operative Diagnosis^PREOPDX"
+13 SET @RET@("P",3)="P^3^Operative Findings^OPFIND"
+14 SET @RET@("P",4)="P^4^Post-Operative Findings^POSTOPDX"
End DoDot:1
DO END
QUIT
+15 IF TYP?1"PG;".N
Begin DoDot:1
+16 SET @RET@("P",$PIECE(TYP,";",2))="PWW^"_$PIECE(TYP,";",2)
End DoDot:1
DO END
QUIT
+17 ; *** SPECIMEN
+18 ; SPH^SP^HIDE_FROM_DESCRIPTION^POSITION^COLLECTION_SAMPLE_HIDE(1,0)^COLLECTION_SAMPLE_DEFAULT
+19 IF TYP?1"SP;".N
Begin DoDot:1
+20 SET @RET@("S",0)="SPH^"_$PIECE(TYP,";",2)_"^^0^^"_$$FIND1^DIC(62,,"X","AP SPECIMEN")
End DoDot:1
DO END
+21 QUIT
+22 ;
SPEC(RET,IEN) ; RPC: ORWLRAP1 SPEC
+1 ; *This returns the default specimen list.
+2 ;
+3 ; RETURN
+4 ; 0 (1,0)ALLOW_OTHER^(1,0)RESTRICT_MULTIPLE
+5 ; # IEN^SPECIMEN_NAME
+6 ;
+7 NEW C,SP
+8 SET IEN=$$GETIEN(+$GET(IEN))
SET RET=$NAME(^TMP($JOB,"SPEC ORWLRAP1"))
KILL @RET
SET @RET@(0)=0
+9 if 'IEN
QUIT
if '$DATA(^ORD(101.45,IEN))
QUIT
+10 SET @RET@(0)=+$PIECE($GET(^ORD(101.45,IEN,0)),U,2)_U_+$PIECE($GET(^ORD(101.45,IEN,0)),U,3)
DO SPEC1
+11 if '$PIECE($GET(^ORD(101.45,IEN,3,0)),U,4)
QUIT
+12 SET C=$ORDER(@RET@(""),-1)+1
+13 SET SP=""
FOR
SET SP=$ORDER(^ORD(101.45,IEN,3,"S",SP))
if SP=""
QUIT
Begin DoDot:1
+14 SET @RET@(C)=$ORDER(^ORD(101.45,IEN,3,"S",SP,""))_U_SP
SET C=C+1
End DoDot:1
+15 QUIT
+16 ;
SPEC1() ; Lab list of specimens for this test
+1 NEW OROUT,IDX
+2 if 'IEN
QUIT
+3 SET IDX=+$PIECE($GET(^ORD(101.45,IEN,0)),U,4)
+4 if 'IDX
QUIT
+5 DO COLL^LR7OR3(+$$GET1^DIQ(101.43,IDX,2),.OROUT)
if '$GET(OROUT("Specimens"))
QUIT
+6 SET CT=0
FOR
SET CT=$ORDER(OROUT("Specimens",CT))
if 'CT
QUIT
Begin DoDot:1
+7 SET @RET@(CT)=OROUT("Specimens",CT)
End DoDot:1
+8 QUIT
+9 ;
+10 ; SUPPORTING APIs ------------------------------------------------------------
+11 ;
NRQ(RQ,NM) ; Add * to name if required
+1 if RQ
QUIT "*"_NM
+2 QUIT NM
+3 ;
VWL(ND0,ND1,IENS) ; Add value list as pipe delimited string
+1 NEW V,STR
+2 SET V=""
FOR
SET V=$ORDER(^ORD(101.45,IEN,ND0,ND1,1,IENS,1,"B",V))
if V=""
QUIT
Begin DoDot:1
+3 SET STR=$SELECT($DATA(STR):STR_"|"_$$EXT(1),1:$$EXT(1))_$SELECT(ND0=2:";"_$$EXT(2)_"-"_$$EXT(4)_";"_$$EXT(3),1:";"_$$EXT(2))
End DoDot:1
+4 QUIT $GET(STR)
+5 ;
EXT(PC) ; Extend Value
+1 if '$GET(PC)
QUIT ""
+2 NEW VI
SET VI=$ORDER(^ORD(101.45,IEN,ND0,ND1,1,IENS,1,"B",V,""))
+3 QUIT $PIECE($GET(^ORD(101.45,IEN,ND0,ND1,1,IENS,1,+VI,0)),U,PC)
+4 ;
END ; Clean Up
+1 IF $ORDER(@RET@(""),-1)?.A
KILL @RET@(0)
QUIT
+2 if $ORDER(@RET@(""),-1)
KILL @RET@(0)
+3 QUIT
+4 ;
APOITEMS(Y,QOCALL,SHOWALL,CODE,NATFLAG,ACCESS) ; Subset of AP orderable items
+1 ; Y(n)=IEN^.01 Name^.01 Name -or- IEN^Synonym <.01 Name>^.01 Name
+2 ; QOCALL = Allow quick orders
+3 ; SHOWALL = Show inactive entries
+4 ; CODE: 0 = List only entries already in File 101.45
+5 ; 1 = List only entries not already in File 101.45
+6 ; NATFLAG = Add National Standard flag as piece 4 of the data
+7 ; ACCESS - List of allowed display groups
+8 ;
+9 NEW I,IEN,X,CURTM,FROM,XREF,LABIEN,INACTIVE,CHKACCESS,LRCODE,ORTESTIEN,ORLABOK
+10 NEW ORLRFILTER
+11 SET QOCALL=+$GET(QOCALL)
SET CODE=+$GET(CODE)
SET NATFLAG=+$GET(NATFLAG)
SET SHOWALL=+$GET(SHOWALL)
+12 SET ACCESS=$GET(ACCESS)
SET CHKACCESS=($LENGTH(ACCESS)>1)
+13 SET I=0
SET FROM=""
SET XREF="S.AP"
SET CURTM=$$NOW^XLFDT
+14 SET ORLRFILTER=+$$GET^XPAR("SYS","OR LR ORDERABLE ITEM FILTERING",1,"I")
+15 FOR
SET FROM=$ORDER(^ORD(101.43,XREF,FROM))
if FROM=""
QUIT
Begin DoDot:1
+16 SET IEN=""
FOR
SET IEN=$ORDER(^ORD(101.43,XREF,FROM,IEN))
if 'IEN
QUIT
Begin DoDot:2
+17 IF '$$OK4CPRS(IEN)
QUIT
+18 SET LABIEN=+$ORDER(^ORD(101.45,"C",IEN,0))
+19 SET INACTIVE=$SELECT(LABIEN:+$PIECE($GET(^ORD(101.45,LABIEN,0)),U,6),1:0)
+20 IF CODE=0
IF 'LABIEN
QUIT
+21 IF CODE=1
IF LABIEN
QUIT
+22 IF 'SHOWALL
IF INACTIVE
QUIT
+23 IF CHKACCESS
Begin DoDot:3
+24 SET LRCODE=$PIECE($GET(^ORD(101.43,IEN,"LR")),U,6)
+25 IF LRCODE=""
SET LRCODE="CH"
End DoDot:3
IF ACCESS'[(U_LRCODE_U)
QUIT
+26 SET X=$GET(^ORD(101.43,XREF,FROM,IEN))
+27 IF +$PIECE(X,U,3)
IF $PIECE(X,U,3)<CURTM
QUIT
+28 IF 'QOCALL
IF $PIECE(X,U,5)
QUIT
+29 IF ORLRFILTER
IF '$$CHKLABDIV^ORWDX2(IEN,XREF)
QUIT
+30 SET I=I+1
+31 IF 'X
SET Y(I)=IEN_U_$PIECE(X,U,2)_U_$PIECE(X,U,2)
+32 IF '$TEST
SET Y(I)=IEN_U_$PIECE(X,U,2)_$CHAR(9)_"<"_$PIECE(X,U,4)_">"_U_$PIECE(X,U,4)
+33 IF NATFLAG
SET $PIECE(Y(I),U,4)=$SELECT(LABIEN:+$PIECE($GET(^ORD(101.45,LABIEN,0)),U,5),1:0)
+34 IF SHOWALL
IF INACTIVE
SET $PIECE(Y(I),U,2)=$PIECE(Y(I),U,2)_" <Inactive>"
End DoDot:2
End DoDot:1
+35 QUIT
+36 ;
OK4CPRS(ORDITEM,QUICK) ; Determines if an orderable item is allowed for AP Dialogs
+1 ; Also used as a screen by the LR OTHER LAB AP TESTS order dialog
+2 NEW LABTEST,OK,LABIEN,NAME,X
+3 SET OK=0
+4 SET LABTEST=$PIECE($GET(^ORD(101.43,ORDITEM,0)),U,2)
+5 SET LABTEST=$SELECT($PIECE(LABTEST,";",2)="99LRT":+LABTEST,1:0)
+6 IF 'LABTEST
QUIT 0
+7 IF $$OK4CPRS^LRAPDLG(LABTEST)
SET OK=1
+8 IF OK
IF $GET(QUICK)
Begin DoDot:1
+9 SET OK=0
+10 SET LABIEN=+$ORDER(^ORD(101.45,"C",ORDITEM,0))
IF 'LABIEN
QUIT
+11 IF +$PIECE($GET(^ORD(101.45,LABIEN,0)),U,6)
QUIT
+12 SET NAME=$PIECE($GET(^ORD(101.43,ORDITEM,0)),U)
IF NAME=""
QUIT
+13 SET X=$GET(^ORD(101.43,"S.AP",NAME,ORDITEM))
IF X=""
QUIT
+14 IF +$PIECE(X,U,3)
IF $PIECE(X,U,3)<$$NOW^XLFDT
QUIT
+15 SET OK=1
End DoDot:1
+16 QUIT OK
+17 ;
APORDITM(Y,QOCALL,ACCESS) ; Subset of AP orderable items
+1 DO APOITEMS(.Y,$GET(QOCALL),,,,$GET(ACCESS))
+2 QUIT
+3 ;
APDLGS ; Update AP Order Dialogs - Entry point for Option ORCM UPDATE AP DIALOGS
+1 NEW RESPONSE,ACTION,DLGIEN,EDITIEN,OIIEN,NAME,X0,I,NATSTAND,ORAPDLGEDIT
+2 ; Disables NAME field override
SET ORAPDLGEDIT=1
+3 FOR
Begin DoDot:1
+4 WRITE !!,"Update Anatomic Pathology Order Dialogs",!
+5 SET RESPONSE=$$GETAPIENS
+6 SET ACTION=$PIECE(RESPONSE,U)
if (ACTION="")!(ACTION="R")
QUIT
+7 SET DLGIEN=$PIECE(RESPONSE,U,2)
SET OIIEN=$PIECE(RESPONSE,U,3)
SET NATSTAND=$PIECE(RESPONSE,U,4)
+8 SET EDITIEN=0
+9 IF ACTION="E"
SET EDITIEN=DLGIEN
+10 IF "^C^N^"[(U_ACTION_U)
Begin DoDot:2
+11 NEW FDA,MSG,IEN
+12 IF 'OIIEN
SET ACTION="R"
QUIT
+13 SET NAME=$PIECE($GET(^ORD(101.43,OIIEN,0)),U)
+14 IF NAME=""
WRITE !,"Orderable Item not found!",!
SET ACTION="R"
QUIT
+15 SET FDA(101.45,"+1,",.01)=NAME
SET FDA(101.45,"+1,",.04)=OIIEN
+16 ; new entry starts as inactive
SET FDA(101.45,"+1,",.06)=1
+17 IF ACTION="C"
Begin DoDot:3
+18 SET X0=$GET(^ORD(101.45,DLGIEN,0))
+19 SET FDA(101.45,"+1,",.02)=$PIECE(X0,U,2)
+20 SET FDA(101.45,"+1,",.03)=$PIECE(X0,U,3)
End DoDot:3
+21 DO UPDATE^DIE("","FDA","IEN","MSG")
+22 IF ($DATA(MSG)>0)!('$GET(IEN(1)))
WRITE !,"Error creating new entry. Please try again later."
SET ACTION="R"
QUIT
+23 SET EDITIEN=IEN(1)
+24 IF ACTION="C"
Begin DoDot:3
+25 FOR I=1:1:4
IF $DATA(^ORD(101.45,DLGIEN,I))
MERGE ^ORD(101.45,EDITIEN,I)=^ORD(101.45,DLGIEN,I)
End DoDot:3
End DoDot:2
if ACTION="R"
QUIT
+26 IF EDITIEN
Begin DoDot:2
+27 NEW DA,DIE,DR
+28 SET DIE="^ORD(101.45,"
SET DA=+EDITIEN
+29 IF NATSTAND
SET DR="[OR AP DIALOG ACTIVATE ONLY]"
+30 IF '$TEST
SET DR="[OR AP DIALOG EDIT TEMPLATE]"
+31 DO ^DIE
End DoDot:2
End DoDot:1
if ACTION=""
QUIT
+32 QUIT
+33 ;
GETAPIENS() ;
+1 NEW IDX,OILIST,ITEM,FLAG,HASFLAGS,CANEDIT,MAX,UMAX,ACTION,ACTIONS,INDEX
+2 NEW EDITIDX,TXT,NEWIDX,EDITIEN,NEWIEN,EDITNAME,NEWNAME,MSG,NATFLAG
+3 NEW DA,DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT,DONE,UNASSIGNED,CANCOPY,ACTCOUNT
+4 DO APOITEMS(.UNASSIGNED,0,1,1)
SET UMAX=+$ORDER(UNASSIGNED(9999999),-1)
SET CANCOPY=(UMAX>0)
+5 DO APOITEMS(.OILIST,0,1,0,1)
SET MAX=+$ORDER(OILIST(9999999),-1)
SET CANEDIT=(MAX>0)
+6 SET (HASFLAGS,EDITIDX,NEWIDX)=0
SET (ACTION,ACTIONS)=""
+7 SET IDX=0
FOR
SET IDX=$ORDER(OILIST(IDX))
if ('IDX)!HASFLAGS
QUIT
Begin DoDot:1
+8 IF $PIECE(OILIST(IDX),U,4)=1
SET HASFLAGS=1
End DoDot:1
+9 WRITE !,"Before you can copy existing anatomic pathology order dialogs,"
+10 WRITE !,"or create new order dialogs, you must work with your laboratory"
+11 WRITE !,"application coordinator to create new, active anatomic pathology"
+12 WRITE !,"tests in the LABORATORY TEST File (#60) that are mapped to a"
+13 WRITE !,"CPRS SCREEN.",!
+14 IF CANCOPY
Begin DoDot:1
+15 DO ADDACTION("N")
+16 IF MAX
DO ADDACTION("C")
End DoDot:1
+17 IF CANEDIT
DO ADDACTION("E")
+18 IF ACTIONS=""
QUIT ""
+19 SET ACTCOUNT=$LENGTH(ACTIONS,";")
+20 IF ACTCOUNT=1
SET ACTION=$EXTRACT(ACTIONS,1)
+21 IF '$TEST
Begin DoDot:1
+22 SET TXT=""
SET INDEX=0
SET DIR(0)="SOB^"_ACTIONS
+23 FOR IDX=1:1:ACTCOUNT
SET ACTION=$PIECE($PIECE(ACTIONS,";",IDX),":")
Begin DoDot:2
+24 DO ADD(.TXT,$$GETATXT(ACTION),$SELECT(IDX<ACTCOUNT:", ",1:" or "))
+25 DO ADDDESC(ACTION)
End DoDot:2
+26 SET DIR("A")=TXT
SET DIR("?")=" "
+27 DO ^DIR
SET ACTION=$SELECT($DATA(DIRUT):"",1:$GET(Y))
End DoDot:1
+28 IF ACTION=""
QUIT ""
+29 ; Get OILIST array index (in EDITIDX) for Copy or Edit
+30 IF "^C^E^"[(U_ACTION_U)
Begin DoDot:1
+31 WRITE !!,"Existing Anatomic Pathology Order Dialogs:",!!
+32 SET IDX=0
FOR
SET IDX=$ORDER(OILIST(IDX))
if 'IDX
QUIT
Begin DoDot:2
+33 SET ITEM=OILIST(IDX)
SET FLAG=$SELECT($PIECE(ITEM,U,4)=1:"*",1:" ")
+34 WRITE ?1,IDX,?5,FLAG_$PIECE(ITEM,U,2),!
End DoDot:2
+35 IF HASFLAGS
WRITE !,"* Indicates a National Standard.",!
+36 KILL DA,DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
+37 SET DIR(0)="NOA^1:"_MAX_":0"
+38 SET DIR("A")="Select Order Dialog to "_$$GETATXT(ACTION)_" (1-"_MAX_"): "
+39 DO ^DIR
IF $DATA(DIRUT)
SET ACTION=""
QUIT
+40 WRITE !," ",$PIECE($GET(OILIST(+$GET(Y))),U,2),!
+41 SET EDITIDX=+$GET(Y)
IF EDITIDX=0
SET ACTION="R"
End DoDot:1
+42 ; Get UNASSIGNED array Index (in NEWIDX) for New or Copy
+43 IF "^C^N^"[(U_ACTION_U)
Begin DoDot:1
+44 WRITE !!,"Anatomic Pathology Orderable Items not assigned to an Order Dialog:",!!
+45 SET IDX=0
FOR
SET IDX=$ORDER(UNASSIGNED(IDX))
if 'IDX
QUIT
Begin DoDot:2
+46 WRITE ?1,IDX,?5,$PIECE(UNASSIGNED(IDX),U,2),!
End DoDot:2
+47 KILL DA,DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
+48 SET DIR(0)="NOA^1:"_UMAX_":0"
+49 IF ACTION="N"
SET TXT="New"
+50 IF '$TEST
SET TXT="Copied"
+51 SET DIR("A")="Attach "_TXT_" Order Dialog to which Orderable Item? (1-"_UMAX_"): "
+52 DO ^DIR
IF $DATA(DIRUT)
SET ACTION=""
QUIT
+53 WRITE !," ",$PIECE($GET(UNASSIGNED(+$GET(Y))),U,2),!
+54 SET NEWIDX=+$GET(Y)
IF NEWIDX=0
SET ACTION="R"
End DoDot:1
+55 if (ACTION="")!(ACTION="R")
QUIT ACTION
+56 SET EDITIEN=$PIECE($GET(OILIST(EDITIDX)),U)
IF EDITIEN
SET EDITIEN=$ORDER(^ORD(101.45,"C",EDITIEN,0))
+57 SET EDITNAME=$PIECE($GET(OILIST(EDITIDX)),U,2)_" order dialog"
+58 SET NEWIEN=$PIECE($GET(UNASSIGNED(NEWIDX)),U)
+59 SET NEWNAME=$PIECE($GET(UNASSIGNED(NEWIDX)),U,2)_" orderable item"
+60 KILL DA,DIR,X,Y,DTOUT,DUOUT,DIRUT,DIROUT
+61 WRITE !
+62 SET DIR(0)="YA"
SET DIR("B")="NO"
SET TXT=""
+63 IF ACTION="N"
SET TXT="Create new order dialog and link it to "_NEWNAME
+64 IF ACTION="C"
SET TXT="Copy "_EDITNAME_" and link it to "_NEWNAME
+65 IF ACTION="E"
SET TXT="Edit "_EDITNAME
+66 IF TXT'=""
Begin DoDot:1
+67 SET TXT=TXT_"? (Yes or No): "
+68 DO WRAP^ORUTL(TXT,"DIR(""A"")",1,0,2,0,70)
+69 SET IDX=$ORDER(DIR("A",99999),-1)
SET DIR("A")=DIR("A",IDX)
KILL DIR("A",IDX)
+70 DO ^DIR
IF $DATA(DIRUT)
SET ACTION=""
QUIT
+71 IF $GET(Y)'=1
SET ACTION="R"
End DoDot:1
+72 SET NATFLAG=""
IF ACTION="E"
IF +EDITIEN
IF $PIECE($GET(^ORD(101.45,EDITIEN,0)),U,5)
SET NATFLAG=1
+73 QUIT ACTION_U_EDITIEN_U_NEWIEN_U_NATFLAG
+74 ;
ADDACTION(ACTION) ; Add Action Text to TEXT
+1 NEW ATXT
SET ATXT=ACTION_":"_$$GETATXT(ACTION)
+2 DO ADD(.ACTIONS,ATXT,";")
+3 QUIT
+4 ;
ADD(TEXT,TEXT2,PREFIX) ; Add TEXT2 to TEXT, insert PREFIX between the two if TEXT '= ""
+1 NEW RESULT
+2 SET RESULT=TEXT
+3 IF TEXT'=""
SET RESULT=RESULT_PREFIX
+4 SET RESULT=RESULT_TEXT2
+5 SET TEXT=RESULT
+6 QUIT
+7 ;
GETATXT(ACTION) ; Get Action Text
+1 IF ACTION="N"
QUIT "New"
+2 IF ACTION="C"
QUIT "Copy"
+3 IF ACTION="E"
QUIT "Edit"
+4 QUIT "*** ERROR: INVALID ACTION """_ACTION_""""
+5 ;
ADDQ(TEXT) ; Add TEXT to DIR("?",INDEX) or RESULT
+1 SET INDEX=INDEX+1
+2 SET DIR("?",INDEX)=TEXT
+3 QUIT
+4 ;
ADDDESC(ACTION) ; Get action description
+1 IF ACTION="N"
Begin DoDot:1
+2 DO ADDQ("(N)ew will create a new order dialog, link it to an existing,")
+3 DO ADDQ(" unassigned, anatomic pathology orderable item, and allow")
+4 DO ADDQ(" you to edit the new order dialog.")
+5 DO ADDQ(" ")
End DoDot:1
QUIT
+6 IF ACTION="C"
Begin DoDot:1
+7 DO ADDQ("(C)opy will copy an existing order dialog to a new order dialog,")
+8 DO ADDQ(" link that dialog to an existing, unassigned, anatomic pathology")
+9 DO ADDQ(" orderable item, and allow you to edit the copied order dialog.")
+10 DO ADDQ(" ")
End DoDot:1
QUIT
+11 IF ACTION="E"
Begin DoDot:1
+12 NEW ETXT
+13 SET ETXT="(E)dit allows you to edit an existing order dialog."
+14 IF HASFLAGS
SET ETXT=ETXT_" National"
+15 DO ADDQ(ETXT)
+16 IF HASFLAGS
DO ADDQ(" Standard dialogs may only be activated/inactivated.")
+17 DO ADDQ(" ")
End DoDot:1
QUIT
+18 DO ADDQ($$GETATXT(ACTION))
+19 QUIT
