- ORCMEDT0 ;SLC/MKB-Dialog Utilities ;17-Jun-2010 14:57;PLS
- ;;3.0;ORDER ENTRY/RESULTS REPORTING;**46,60,190,1005,215,243,296,1010**;Dec 17, 1997;Build 47
- ; Modified - 12/03/09 - IHS/MSC/MGH - Line SAVE+7 - Fix for disappearing leading '0'.
- ; 04/22/10 - IHS/MSC/PLS - Line SAVE+10 - Fix for empty WP fields
- DIALOG(TYPE) ; -- Get Dialog file entry
- N X,Y,Z,D,DIC,DIE,DIK,DA,DR,DLAYGO,ORPKG,ORDLG,ORIT,OROI,I,IDX
- 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 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
- . . I TYPE="N" D ;Patch 1005
- . . .I $P(ITM,"^",2)="QTY"&($E(VALUE,1,1)=".") S VALUE="0"_VALUE
- . . S:TYPE'="W" ^ORD(101.41,ORQDLG,6,CNT,1)=VALUE
- . . ;M:TYPE="W" ^ORD(101.41,ORQDLG,6,CNT,2)=@VALUE
- . . I TYPE="W",$L($G(VALUE)) M ^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
- ORCMEDT0 ;SLC/MKB-Dialog Utilities ;17-Jun-2010 14:57;PLS
- +1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**46,60,190,1005,215,243,296,1010**;Dec 17, 1997;Build 47
- +2 ; Modified - 12/03/09 - IHS/MSC/MGH - Line SAVE+7 - Fix for disappearing leading '0'.
- +3 ; 04/22/10 - IHS/MSC/PLS - Line SAVE+10 - Fix for empty WP fields
- 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 SET ORPKG="ORDER ENTRY/RESULTS REPORTING"
- SET DIC="^ORD(101.41,"
- SET DIC(0)="AEQLZ"
- +3 SET DIC("S")="I $P(^(0),U,4)="""_TYPE_""""
- SET DLAYGO=101.41
- +4 SET DIC("A")="Select "_$SELECT(TYPE="Q":"QUICK ORDER",TYPE="O":"ORDER SET",TYPE="A":"ACTION",1:"ORDER DIALOG")_" NAME: "
- +5 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 IF Y>0
- SET ORDG=+Y
- SET $PIECE(^ORD(101.41,ORDLG,0),U,5)=+Y
- QUIT
- +12 WRITE !,$PIECE(^ORD(101.41,ORDLG,0),U)_" quick order dialog DELETED!",!
- +13 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 ;Patch 1005
- IF TYPE="N"
- Begin DoDot:3
- +8 IF $PIECE(ITM,"^",2)="QTY"&($EXTRACT(VALUE,1,1)=".")
- SET VALUE="0"_VALUE
- End DoDot:3
- +9 IF TYPE'="W"
- SET ^ORD(101.41,ORQDLG,6,CNT,1)=VALUE
- +10 ;M:TYPE="W" ^ORD(101.41,ORQDLG,6,CNT,2)=@VALUE
- +11 IF TYPE="W"
- IF $LENGTH($GET(VALUE))
- MERGE ^ORD(101.41,ORQDLG,6,CNT,2)=@VALUE
- +12 SET ^ORD(101.41,ORQDLG,6,"D",PROMPT,CNT)=""
- End DoDot:2
- End DoDot:1
- +13 SET ^ORD(101.41,ORQDLG,6,0)="^101.416^"_CNT_U_CNT
- +14 SET INP=+$ORDER(^ORD(100.98,"B","INPATIENT MEDICATIONS",""))
- +15 SET UD=+$ORDER(^ORD(100.98,"B","UNIT DOSE MEDICATIONS",""))
- +16 IF +$GET(ORDG)>0
- IF ORDG=INP
- IF UD>0
- SET ORDG=UD
- +17 IF $GET(ORDG)
- SET $PIECE(^ORD(101.41,ORQDLG,0),U,5)=+ORDG
- +18 QUIT
- +19 ;
- 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
