- 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 Jan 18, 2025@03:37:48 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