- ORCMEDT0 ;SLC/MKB-Dialog Utilities ;Jun 17, 2022@14:32:43
- ;;3.0;ORDER ENTRY/RESULTS REPORTING;**46,60,190,215,243,296,389,539,569**;Dec 17, 1997;Build 23
- DIALOG(TYPE) ; -- Get Dialog file entry
- N X,Y,Z,D,DIC,DIE,DIK,DA,DR,DLAYGO,ORPKG,ORDLG,ORIT,OROI,I,IDX
- ;389/WAT - Sites have deleted entries in 101.41 w/o also removing pointers ergo reusing IENs can result in other file entries pointing back to
- ;incorrect order dialog entries. Adding a check if 3rd piece is not highest available IEN, then reset accordingly
- N ORD03,ORD03TMP S ORD03=$P(^ORD(101.41,0),U,3) S ORD03TMP=$$CHKDA(ORD03)
- I ORD03TMP'=ORD03 S $P(^ORD(101.41,0),U,3)=ORD03TMP
- S ORPKG="ORDER ENTRY/RESULTS REPORTING",DIC="^ORD(101.41,",DIC(0)="AEQLZ"
- S DIC("S")="I $P(^(0),U,4)="""_TYPE_"""",DLAYGO=101.41
- S DIC("A")="Select "_$S(TYPE="Q":"QUICK ORDER",TYPE="O":"ORDER SET",TYPE="A":"ACTION",1:"ORDER DIALOG")_" NAME: "
- S DIC("DR")="4///"_TYPE_$S(TYPE="D":";7///^S X=ORPKG",1:"")
- D0 S D="AB" D IX^DIC I Y'>0 S ORDLG="^" G DQ
- S ORDLG=+Y,ORDG=$P(Y(0),U,5) G:'$P(Y,U,3) DQ ; not a new entry
- I $O(^ORD(101.41,"AB",$P(Y,U,2),0))'=+Y W $C(7),!,"Another entry already exists by this name!",! D DEL(+Y) G D0
- I TYPE="D" D G:ORDLG="^" DQ ;new dialog
- . S DA=ORDLG,DR="5R",DIE=DIC,ORIT=$P(Y,U,2) D ^DIE
- . S ORDG=+$P($G(^ORD(101.41,ORDLG,0)),U,5)
- . I 'ORDG W $C(7),!,"Deleting <"_ORIT_"> ..." S DA=ORDLG,DIK=DIC D ^DIK S ORDLG="^" Q
- . S ORIT=$$OI^ORCMEDT3(+ORDG) S:ORIT="^" ORDLG="^"
- I TYPE="Q" D G DQ ;new quick order
- . S DIC="^ORD(100.98,",DIC(0)="AEQM",DIC("S")="I $P(^(0),U,4)"
- . S DIC("A")="TYPE OF QUICK ORDER: " D ^DIC
- . ;I Y>0,$P($G(^ORD(100.98,+Y,0)),U)="ANATOMIC PATHOLOGY" S Y=0 W !,!,"ANATOMIC PATHOLOGY does not support quick orders at this time.",!
- . I Y>0 S ORDG=+Y,$P(^ORD(101.41,ORDLG,0),U,5)=+Y Q
- . W !,$P(^ORD(101.41,ORDLG,0),U)_" quick order dialog DELETED!",!
- . S DA=ORDLG,DIK="^ORD(101.41,",ORDLG="^" D ^DIK
- D1 I $$COPY^ORCMEDIT(TYPE) D ;copy an existing dialog?
- . K DLAYGO,DIC("B") S DIC(0)="AEQZ",DIC("A")="Select "_$S(TYPE="Q":"QUICK ORDER",TYPE="O":"ORDER SET",1:"ORDER DIALOG")_" TO COPY: "
- . D ^DIC Q:Y'>0 W !,"Copying ..."
- . F I=2,6,8,9 S $P(^ORD(101.41,ORDLG,0),U,I)=$P(Y(0),U,I)
- . S:TYPE'="D" $P(^ORD(101.41,ORDLG,0),U,5)=$P(Y(0),U,5) ;skip DG if Dlg
- . S:$L($P(Y(0),U,2)) ^ORD(101.41,"C",$$UP^XLFSTR($P(Y(0),U,2)),ORDLG)="" ;disp text
- . F I=2,3,3.1,4,5,6,7,9,10 I $D(^ORD(101.41,+Y,I)) M ^ORD(101.41,ORDLG,I)=^ORD(101.41,+Y,I)
- . I $P(Y(0),U,7) S DA=ORDLG,DIE=DIC,DR="7///"_$P(Y(0),U,7) D ^DIE
- . K DA S DA(1)=ORDLG,DIK="^ORD(101.41,"_ORDLG_",10,",DIK(1)="2^AD" D ENALL^DIK
- D2 I TYPE="D",$G(ORIT) D ;stuff in default OI
- . S DA=ORDLG,DR="2///"_$P(ORIT,U,2),DIE="^ORD(101.41," D ^DIE
- . S OROI=$$PTR^ORCD("OR GTX ORDERABLE ITEM"),DA=$O(^ORD(101.41,ORDLG,10,"D",OROI,0)) I 'DA D Q:'DA ;create OI prompt
- .. S X=+$O(^ORD(101.41,ORDLG,10,"B",0)),X=$S(X=0:1,1:X-.1) ;get Seq#
- .. K DA,DIC S DIC="^ORD(101.41,"_ORDLG_",10,",DIC(0)="L",DA(1)=ORDLG
- .. D ^DIC Q:Y'>0 S DA=+Y ;S DIC("P")=$P(^DD(101.41,10,0),U,2)
- .. S Z=+$O(^ORD(101.41,ORDLG,10,"ATXT",0)),Z=$S(Z=0:1,1:Z-.1) ;TxtSeq#
- .. S ^ORD(101.41,ORDLG,10,DA,0)=X_U_OROI_"^^Order: ^^1",^(2)=Z
- .. S ^ORD(101.41,"AD",OROI,ORDLG,DA)="",^ORD(101.41,ORDLG,10,"B",X,DA)="",^ORD(101.41,ORDLG,10,"D",OROI,DA)="",^ORD(101.41,ORDLG,10,"ATXT",X,DA)=""
- . S IDX="S."_$P($G(^ORD(100.98,+ORDG,0)),U,3)
- . S $P(^ORD(101.41,ORDLG,10,DA,0),U,8)=1,$P(^(0),U,10)=IDX,^(3)="I 0 ;uneditable",^(7)="S Y="_+ORIT
- DQ Q ORDLG
- ;
- DEL(DA) ; -- delete bad entry in Order Dialog file
- N DIK S DIK="^ORD(101.41," D:$G(DA) ^DIK
- Q
- ;
- SAVE ; -- Save ORDG, responses in ORDIALOG to dialog ORQDLG
- N PROMPT,CNT,ITM,TYPE,INST,VALUE,INP,UD K ^ORD(101.41,ORQDLG,6)
- S (PROMPT,CNT)=0 F S PROMPT=$O(ORDIALOG(PROMPT)) Q:PROMPT'>0 D
- . S ITM=ORDIALOG(PROMPT),TYPE=$E(ORDIALOG(PROMPT,0))
- . S INST=0 F S INST=$O(ORDIALOG(PROMPT,INST)) Q:INST'>0 D
- . . S VALUE=$G(ORDIALOG(PROMPT,INST)),CNT=CNT+1
- . . S ^ORD(101.41,ORQDLG,6,CNT,0)=+ITM_U_PROMPT_U_INST
- . . S:TYPE'="W" ^ORD(101.41,ORQDLG,6,CNT,1)=VALUE
- . . M:TYPE="W" ^ORD(101.41,ORQDLG,6,CNT,2)=@VALUE
- . . S ^ORD(101.41,ORQDLG,6,"D",PROMPT,CNT)=""
- S ^ORD(101.41,ORQDLG,6,0)="^101.416^"_CNT_U_CNT
- S INP=+$O(^ORD(100.98,"B","INPATIENT MEDICATIONS",""))
- S UD=+$O(^ORD(100.98,"B","UNIT DOSE MEDICATIONS",""))
- I +$G(ORDG)>0,ORDG=INP,UD>0 S ORDG=UD
- S:$G(ORDG) $P(^ORD(101.41,ORQDLG,0),U,5)=+ORDG
- Q
- ;
- ITEM(Z) ; -- Select new item to add
- N X,Y,DIC,ORDDF,ORERR,I
- S DIC=101.41,DIC(0)="AEQM",DIC("A")="ITEM: "
- I $G(Z) S Z=$P($G(^ORD(101.41,+Z,0)),U) S:$L(Z) DIC("B")=Z
- S DIC("S")="I $P(^(0),U,4)'=""P"""
- IT1 D ^DIC I Y'>0 S Y=$S($D(DUOUT)!$D(DTOUT):"^",1:"") Q Y
- D RECURSV^ORCMEDT5(+Y,+ORMENU,.ORERR) I $D(ORERR) D G IT1
- . W $C(7),!!,"If an item is already included on this menu, it may not be added!"
- . W !,ORERR S I=0 F S I=$O(ORERR(I)) Q:I'>0 W !?18," =>"_ORERR(I)
- Q +Y
- ;
- CHKDA(ORIFN) ; return numerically largest IEN in use
- N ORFLG,ORNEW
- S ORFLG=0
- ;ORIFN - 3rd piece 0 node
- ;ORFLG - Set to 1 when the largest IEN is found
- ;ORNEW - next higher IEN
- Q:$G(ORIFN)=""
- S ORNEW=ORIFN
- F S ORNEW=$O(^ORD(101.41,ORNEW)) D Q:ORFLG=1
- . I +$O(^ORD(101.41,ORNEW))'>0 S ORFLG=1 Q
- I +$G(ORNEW)>ORIFN Q ORNEW
- Q ORIFN
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORCMEDT0 5299 printed Mar 13, 2025@21:33:31 Page 2
- ORCMEDT0 ;SLC/MKB-Dialog Utilities ;Jun 17, 2022@14:32:43
- +1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**46,60,190,215,243,296,389,539,569**;Dec 17, 1997;Build 23
- DIALOG(TYPE) ; -- Get Dialog file entry
- +1 NEW X,Y,Z,D,DIC,DIE,DIK,DA,DR,DLAYGO,ORPKG,ORDLG,ORIT,OROI,I,IDX
- +2 ;389/WAT - Sites have deleted entries in 101.41 w/o also removing pointers ergo reusing IENs can result in other file entries pointing back to
- +3 ;incorrect order dialog entries. Adding a check if 3rd piece is not highest available IEN, then reset accordingly
- +4 NEW ORD03,ORD03TMP
- SET ORD03=$PIECE(^ORD(101.41,0),U,3)
- SET ORD03TMP=$$CHKDA(ORD03)
- +5 IF ORD03TMP'=ORD03
- SET $PIECE(^ORD(101.41,0),U,3)=ORD03TMP
- +6 SET ORPKG="ORDER ENTRY/RESULTS REPORTING"
- SET DIC="^ORD(101.41,"
- SET DIC(0)="AEQLZ"
- +7 SET DIC("S")="I $P(^(0),U,4)="""_TYPE_""""
- SET DLAYGO=101.41
- +8 SET DIC("A")="Select "_$SELECT(TYPE="Q":"QUICK ORDER",TYPE="O":"ORDER SET",TYPE="A":"ACTION",1:"ORDER DIALOG")_" NAME: "
- +9 SET DIC("DR")="4///"_TYPE_$SELECT(TYPE="D":";7///^S X=ORPKG",1:"")
- D0 SET D="AB"
- DO IX^DIC
- IF Y'>0
- SET ORDLG="^"
- GOTO DQ
- +1 ; not a new entry
- SET ORDLG=+Y
- SET ORDG=$PIECE(Y(0),U,5)
- if '$PIECE(Y,U,3)
- GOTO DQ
- +2 IF $ORDER(^ORD(101.41,"AB",$PIECE(Y,U,2),0))'=+Y
- WRITE $CHAR(7),!,"Another entry already exists by this name!",!
- DO DEL(+Y)
- GOTO D0
- +3 ;new dialog
- IF TYPE="D"
- Begin DoDot:1
- +4 SET DA=ORDLG
- SET DR="5R"
- SET DIE=DIC
- SET ORIT=$PIECE(Y,U,2)
- DO ^DIE
- +5 SET ORDG=+$PIECE($GET(^ORD(101.41,ORDLG,0)),U,5)
- +6 IF 'ORDG
- WRITE $CHAR(7),!,"Deleting <"_ORIT_"> ..."
- SET DA=ORDLG
- SET DIK=DIC
- DO ^DIK
- SET ORDLG="^"
- QUIT
- +7 SET ORIT=$$OI^ORCMEDT3(+ORDG)
- if ORIT="^"
- SET ORDLG="^"
- End DoDot:1
- if ORDLG="^"
- GOTO DQ
- +8 ;new quick order
- IF TYPE="Q"
- Begin DoDot:1
- +9 SET DIC="^ORD(100.98,"
- SET DIC(0)="AEQM"
- SET DIC("S")="I $P(^(0),U,4)"
- +10 SET DIC("A")="TYPE OF QUICK ORDER: "
- DO ^DIC
- +11 ;I Y>0,$P($G(^ORD(100.98,+Y,0)),U)="ANATOMIC PATHOLOGY" S Y=0 W !,!,"ANATOMIC PATHOLOGY does not support quick orders at this time.",!
- +12 IF Y>0
- SET ORDG=+Y
- SET $PIECE(^ORD(101.41,ORDLG,0),U,5)=+Y
- QUIT
- +13 WRITE !,$PIECE(^ORD(101.41,ORDLG,0),U)_" quick order dialog DELETED!",!
- +14 SET DA=ORDLG
- SET DIK="^ORD(101.41,"
- SET ORDLG="^"
- DO ^DIK
- End DoDot:1
- GOTO DQ
- D1 ;copy an existing dialog?
- IF $$COPY^ORCMEDIT(TYPE)
- Begin DoDot:1
- +1 KILL DLAYGO,DIC("B")
- SET DIC(0)="AEQZ"
- SET DIC("A")="Select "_$SELECT(TYPE="Q":"QUICK ORDER",TYPE="O":"ORDER SET",1:"ORDER DIALOG")_" TO COPY: "
- +2 DO ^DIC
- if Y'>0
- QUIT
- WRITE !,"Copying ..."
- +3 FOR I=2,6,8,9
- SET $PIECE(^ORD(101.41,ORDLG,0),U,I)=$PIECE(Y(0),U,I)
- +4 ;skip DG if Dlg
- if TYPE'="D"
- SET $PIECE(^ORD(101.41,ORDLG,0),U,5)=$PIECE(Y(0),U,5)
- +5 ;disp text
- if $LENGTH($PIECE(Y(0),U,2))
- SET ^ORD(101.41,"C",$$UP^XLFSTR($PIECE(Y(0),U,2)),ORDLG)=""
- +6 FOR I=2,3,3.1,4,5,6,7,9,10
- IF $DATA(^ORD(101.41,+Y,I))
- MERGE ^ORD(101.41,ORDLG,I)=^ORD(101.41,+Y,I)
- +7 IF $PIECE(Y(0),U,7)
- SET DA=ORDLG
- SET DIE=DIC
- SET DR="7///"_$PIECE(Y(0),U,7)
- DO ^DIE
- +8 KILL DA
- SET DA(1)=ORDLG
- SET DIK="^ORD(101.41,"_ORDLG_",10,"
- SET DIK(1)="2^AD"
- DO ENALL^DIK
- End DoDot:1
- D2 ;stuff in default OI
- IF TYPE="D"
- IF $GET(ORIT)
- Begin DoDot:1
- +1 SET DA=ORDLG
- SET DR="2///"_$PIECE(ORIT,U,2)
- SET DIE="^ORD(101.41,"
- DO ^DIE
- +2 ;create OI prompt
- SET OROI=$$PTR^ORCD("OR GTX ORDERABLE ITEM")
- SET DA=$ORDER(^ORD(101.41,ORDLG,10,"D",OROI,0))
- IF 'DA
- Begin DoDot:2
- +3 ;get Seq#
- SET X=+$ORDER(^ORD(101.41,ORDLG,10,"B",0))
- SET X=$SELECT(X=0:1,1:X-.1)
- +4 KILL DA,DIC
- SET DIC="^ORD(101.41,"_ORDLG_",10,"
- SET DIC(0)="L"
- SET DA(1)=ORDLG
- +5 ;S DIC("P")=$P(^DD(101.41,10,0),U,2)
- DO ^DIC
- if Y'>0
- QUIT
- SET DA=+Y
- +6 ;TxtSeq#
- SET Z=+$ORDER(^ORD(101.41,ORDLG,10,"ATXT",0))
- SET Z=$SELECT(Z=0:1,1:Z-.1)
- +7 SET ^ORD(101.41,ORDLG,10,DA,0)=X_U_OROI_"^^Order: ^^1"
- SET ^(2)=Z
- +8 SET ^ORD(101.41,"AD",OROI,ORDLG,DA)=""
- SET ^ORD(101.41,ORDLG,10,"B",X,DA)=""
- SET ^ORD(101.41,ORDLG,10,"D",OROI,DA)=""
- SET ^ORD(101.41,ORDLG,10,"ATXT",X,DA)=""
- End DoDot:2
- if 'DA
- QUIT
- +9 SET IDX="S."_$PIECE($GET(^ORD(100.98,+ORDG,0)),U,3)
- +10 SET $PIECE(^ORD(101.41,ORDLG,10,DA,0),U,8)=1
- SET $PIECE(^(0),U,10)=IDX
- SET ^(3)="I 0 ;uneditable"
- SET ^(7)="S Y="_+ORIT
- End DoDot:1
- DQ QUIT ORDLG
- +1 ;
- DEL(DA) ; -- delete bad entry in Order Dialog file
- +1 NEW DIK
- SET DIK="^ORD(101.41,"
- if $GET(DA)
- DO ^DIK
- +2 QUIT
- +3 ;
- SAVE ; -- Save ORDG, responses in ORDIALOG to dialog ORQDLG
- +1 NEW PROMPT,CNT,ITM,TYPE,INST,VALUE,INP,UD
- KILL ^ORD(101.41,ORQDLG,6)
- +2 SET (PROMPT,CNT)=0
- FOR
- SET PROMPT=$ORDER(ORDIALOG(PROMPT))
- if PROMPT'>0
- QUIT
- Begin DoDot:1
- +3 SET ITM=ORDIALOG(PROMPT)
- SET TYPE=$EXTRACT(ORDIALOG(PROMPT,0))
- +4 SET INST=0
- FOR
- SET INST=$ORDER(ORDIALOG(PROMPT,INST))
- if INST'>0
- QUIT
- Begin DoDot:2
- +5 SET VALUE=$GET(ORDIALOG(PROMPT,INST))
- SET CNT=CNT+1
- +6 SET ^ORD(101.41,ORQDLG,6,CNT,0)=+ITM_U_PROMPT_U_INST
- +7 if TYPE'="W"
- SET ^ORD(101.41,ORQDLG,6,CNT,1)=VALUE
- +8 if TYPE="W"
- MERGE ^ORD(101.41,ORQDLG,6,CNT,2)=@VALUE
- +9 SET ^ORD(101.41,ORQDLG,6,"D",PROMPT,CNT)=""
- End DoDot:2
- End DoDot:1
- +10 SET ^ORD(101.41,ORQDLG,6,0)="^101.416^"_CNT_U_CNT
- +11 SET INP=+$ORDER(^ORD(100.98,"B","INPATIENT MEDICATIONS",""))
- +12 SET UD=+$ORDER(^ORD(100.98,"B","UNIT DOSE MEDICATIONS",""))
- +13 IF +$GET(ORDG)>0
- IF ORDG=INP
- IF UD>0
- SET ORDG=UD
- +14 if $GET(ORDG)
- SET $PIECE(^ORD(101.41,ORQDLG,0),U,5)=+ORDG
- +15 QUIT
- +16 ;
- ITEM(Z) ; -- Select new item to add
- +1 NEW X,Y,DIC,ORDDF,ORERR,I
- +2 SET DIC=101.41
- SET DIC(0)="AEQM"
- SET DIC("A")="ITEM: "
- +3 IF $GET(Z)
- SET Z=$PIECE($GET(^ORD(101.41,+Z,0)),U)
- if $LENGTH(Z)
- SET DIC("B")=Z
- +4 SET DIC("S")="I $P(^(0),U,4)'=""P"""
- IT1 DO ^DIC
- IF Y'>0
- SET Y=$SELECT($DATA(DUOUT)!$DATA(DTOUT):"^",1:"")
- QUIT Y
- +1 DO RECURSV^ORCMEDT5(+Y,+ORMENU,.ORERR)
- IF $DATA(ORERR)
- Begin DoDot:1
- +2 WRITE $CHAR(7),!!,"If an item is already included on this menu, it may not be added!"
- +3 WRITE !,ORERR
- SET I=0
- FOR
- SET I=$ORDER(ORERR(I))
- if I'>0
- QUIT
- WRITE !?18," =>"_ORERR(I)
- End DoDot:1
- GOTO IT1
- +4 QUIT +Y
- +5 ;
- CHKDA(ORIFN) ; return numerically largest IEN in use
- +1 NEW ORFLG,ORNEW
- +2 SET ORFLG=0
- +3 ;ORIFN - 3rd piece 0 node
- +4 ;ORFLG - Set to 1 when the largest IEN is found
- +5 ;ORNEW - next higher IEN
- +6 if $GET(ORIFN)=""
- QUIT
- +7 SET ORNEW=ORIFN
- +8 FOR
- SET ORNEW=$ORDER(^ORD(101.41,ORNEW))
- Begin DoDot:1
- +9 IF +$ORDER(^ORD(101.41,ORNEW))'>0
- SET ORFLG=1
- QUIT
- End DoDot:1
- if ORFLG=1
- QUIT
- +10 IF +$GET(ORNEW)>ORIFN
- QUIT ORNEW
- +11 QUIT ORIFN
