- ORCMEDT5 ;SLC/MKB-Misc menu utilities ;03:29 PM 12 Feb 1999
- ;;3.0;ORDER ENTRY/RESULTS REPORTING;**8,46,296,314,375**;Dec 17, 1997;Build 1
- SEARCH ; -- Search/replace menu items
- N ORDLG
- F S ORDLG=$$DIC Q:ORDLG'>0 D SR1(ORDLG) W !!
- Q
- ;
- SR1(ORX) ; -- list parents, get replacement
- N CNT,DA,DR,DIE,DIK,I,J,ORDAD,ORY,ORNMBR,NUM,ORI,ORDAD,ORNM
- I '$O(^ORD(101.41,"AD",+ORX,0)) W !,$P(ORX,U,2)_" has no menu items." Q
- W @IOF,"Menu items of "_$P(ORX,U,2),!?4,"Name",?69,"Type",!,$$REPEAT^XLFSTR("-",79)
- S (I,ORDAD)=0 F S I=$O(^ORD(101.41,"AD",+ORX,I)) Q:I'>0 D
- . S J=0 F S J=$O(^ORD(101.41,"AD",+ORX,I,J)) Q:J'>0 D
- . . S ORDAD=ORDAD+1,ORDAD(ORDAD)=I_U_J
- . . W !,ORDAD,?4,$P(^ORD(101.41,I,0),U),?69,$$TYPE($P(^(0),U,4))
- W !,$$REPEAT^XLFSTR("-",79)
- S ORY=$$REPLWITH(ORX) Q:ORY="^"
- D SELECT(ORY,ORDAD,.ORNMBR) Q:ORNMBR="^"
- Q:'$$OK W !!,$S(ORY="@":"Removing",1:"Replacing "_$P(ORX,U,2)_" with "_$P(ORY,U,2))_" in:"
- S CNT="" F S CNT=$O(ORNMBR(CNT)) Q:CNT="" D
- . D LOOP($G(ORNMBR(CNT)))
- Q
- LOOP(ORNMBR) ;
- F ORI=1:1:$L(ORNMBR,",") S NUM=$P(ORNMBR,",",ORI) I NUM D
- . S DA(1)=+ORDAD(NUM),DA=$P(ORDAD(NUM),U,2),DIE="^ORD(101.41,"_DA(1)_",10,"
- . S ORDAD=DA(1),ORNM=$P(^ORD(101.41,ORDAD,0),U) W !?3,ORNM_" ..."
- . I '$$VALID(ORY,ORDAD,.ORERR) D Q
- . . W "not "_$S(ORY="@":"removed.",1:"changed."),!?3,">> "_$G(ORERR)
- . . S I=0 F S I=$O(ORERR(I)) Q:I'>0 W !?25,"=>"_ORERR(I)
- . I ORY="@" S DIK=DIE D ^DIK W "done." Q
- . S DR="2////"_+ORY D ^DIE W $S($P(^ORD(101.41,DA(1),10,DA,0),U,2)=+ORY:"done.",1:"error - not replaced.")
- Q
- ;
- TYPE(X) ; -- Returns name of dialog type
- N Y S Y=$S(X="P":"prompt",X="D":"dialog",X="Q":"quick order",X="O":"order set",X="M":"menu",X="A":"action",1:"")
- Q Y
- ;
- DIC() ; -- ^DIC on Order Dialog file
- N X,Y,DIC
- S DIC=101.41,DIC(0)="AEQM",DIC("A")="Search for: "
- S DIC("?")="Enter the name of the dialog component you wish to search for."
- D ^DIC
- Q Y
- ;
- SELECT(ORY,MAX,Y) ; -- Select which Dlgs to replace items
- N X,DIR
- S DIR(0)="LA^1:"_MAX,DIR("A")=$S(ORY="@":"Remove in: ",1:"Replace in: "),DIR("B")=$S(MAX>1:"1-"_MAX,1:"1")
- ; S DIR("?")
- D ^DIR S:$D(DTOUT)!(X["^") Y="^"
- Q
- ;
- OK() ; -- Are you ready?
- N X,Y,DIR
- S DIR(0)="YA",DIR("A")="Are you ready? ",DIR("B")="NO"
- W ! D ^DIR
- Q +Y
- ;
- REPLWITH(ORIT) ; -- Remove item, or select replacement
- N X,Y,DIR,DIC
- S DIR(0)="FAO^1:63",DIR("A")="Replace "_$P(ORIT,U,2)_" with: "
- S DIR("?")="Enter the name of the item you wish to replace this one with, or @ to remove this item; to quit without changing anything, press <return>."
- R1 D ^DIR I X="@" Q "@"
- I $D(DTOUT)!("^"[X) Q "^"
- S DIC=101.41,DIC(0)="EQM" D ^DIC I Y'>0 G R1
- Q Y
- ;
- VALID(ITM,DAD,ERR) ; -- Ck if ITM may be placed on DAD
- N DTYPE,ITYPE,Y S Y=0
- S DTYPE=$P(^ORD(101.41,DAD,0),U,4) I DTYPE="D",$$NMSP^ORCD($P(^(0),U,7))'="OR" S ERR="Only generic ordering dialogs are editable." G VQ
- I ITM="@" S Y=1 G VQ ; ok to delete
- S ITYPE=$P(^ORD(101.41,+ITM,0),U,4)
- I ITYPE="P",DTYPE'="D" S ERR="A prompt may not be added to a "_$$TYPE(DTYPE)_"." G VQ
- I ITYPE="A","DOM"'[DTYPE S ERR="An action may not be added to a "_$$TYPE(DTYPE)_"." G VQ
- I "DQOM"[ITYPE,"OM"'[DTYPE S ERR="A "_$$TYPE(ITYPE)_" may not be added to a "_$$TYPE(DTYPE)_"." G VQ
- D RECURSV(+ITM,DAD,.ERR) I $D(ERR) S Y=0 G VQ
- S Y=1 ; ok
- VQ Q Y
- ;
- RECURSV(ITEM,MENU,MSG) ; -- Return 1 or 0, if recursive reference to ITEM
- N STACK,CNT S STACK=0,CNT=0
- K MSG
- I ITEM=MENU S MSG="Recursive Reference: "_$P($G(^ORD(101.41,ITEM,0)),U) Q ;p375 prevents menu on itself
- D CHKPAR(MENU)
- Q
- CHKPAR(MENU) ; follow tree to check parents
- N PMENU,I
- S STACK=STACK+1,STACK(STACK)=MENU,STACK("B",MENU)=STACK,PMENU=0
- F S PMENU=$O(^ORD(101.41,"AD",MENU,PMENU)) Q:'PMENU D Q:$D(MSG)
- . I PMENU=ITEM D Q
- . . S MSG="Recursive Reference: "_$P(^ORD(101.41,ITEM,0),U)
- . . F I=STACK:-1:1 S CNT=CNT+1,MSG(CNT)=$P(^ORD(101.41,STACK(I),0),U)
- . I $D(STACK("B",PMENU)) Q
- . D CHKPAR(PMENU)
- K STACK(STACK) S STACK=STACK-1
- Q
- ;
- INUSE(MENU) ; -- Returns 1 or 0, if MENU is in use by parameter
- N PARAM,ENT,Y
- S PARAM=$O(^XTV(8989.51,"B","OR ADD ORDERS MENU",0)),Y=0
- S ENT="" F S ENT=$O(^XTV(8989.5,"AC",PARAM,ENT)) Q:ENT="" I $G(^(ENT,1))=MENU S Y=1 Q
- Q Y
- ;
- ASSIGN ; -- Assign menu to user(s)
- D FULL^VALM1
- D EDITPAR^XPAREDIT("OR ADD ORDERS MENU")
- S VALMBCK="R"
- Q
- ;
- INQ ; -- Inquire to Order Dialog file
- N X,Y,DIC,DA,DR,DIQ
- S DIC="^ORD(101.41,",DIC(0)="AEQM"
- F D ^DIC Q:Y'>0 S DA=+Y W ! D EN^DIQ W !
- Q
- ;
- OUTPUT(ORY) ; -- Output Xform for Value field of Response multiple
- N ORDIALOG,ORP,ORZ S ORZ=ORY
- S ORP=$P($G(^ORD(101.41,D0,6,D1,0)),U,2)
- I ORP S ORDIALOG(ORP,0)=$P($G(^ORD(101.41,ORP,1)),U,1,2),ORDIALOG(ORP,1)=ORY,ORZ=$$EXT^ORCD(ORP,1)
- Q ORZ
- ;
- AOPAR ; -- List of add order menus assigned to users
- N BY,DHD,DIC,FLDS,FR,TO
- S DIC=8989.5
- S FR="OR ADD ORDERS MENU,?",TO="OR ADD ORDERS MENU,?"
- S BY="@.02,@1;S2;""Add order menu: """
- S DHD="CPRS Add order menu list"
- S FLDS="VALUE;N;""Menu"",ENTITY;""User/Location/etc."";C40"
- D EN1^DIP
- Q
- ;
- DISABLE ; -- Disable order dialogs
- N X,Y,DIC,DIR,ORDIS,ORI K ^TMP("ORDISABLE",$J)
- S DIC=101.41,DIC(0)="AEQM",DIC("A")="Select ORDER DIALOG: ",DIC("?")="Enter the name of an order dialog you wish to disable."
- S DIC("W")="I $L($P(^(0),U,3)) W !?3,"">> disabled: ""_$P(^(0),U,3)"
- F D ^DIC Q:Y'>0 S ^TMP("ORDISABLE",$J,+Y)="" S DIC("A")="ANOTHER ONE: "
- Q:'$O(^TMP("ORDISABLE",$J,0)) ;none selected
- W !!,"Enter a message to disable the dialog(s), or @ to enable again."
- S DIR(0)="FAO^1:40",DIR("A")="MESSAGE: "
- S DIR("?")="Enter up to 40 characters explaining why use of this dialog has been disabled that will display if the dialog is selected, or @ to enable the dialog again."
- D ^DIR G:$D(DTOUT)!$D(DUOUT)!(X="") DQ S ORDIS=X
- I '$$OK W !,"Nothing "_$S(ORDIS="@":"en",1:"dis")_"abled." H 1 G DQ
- S ORI=0 F S ORI=$O(^TMP("ORDISABLE",$J,ORI)) Q:ORI'>0 S $P(^ORD(101.41,ORI,0),U,3)=$S(ORDIS="@":"",1:ORDIS) W "."
- W !,"done." H 1
- DQ K ^TMP("ORDISABLE",$J)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORCMEDT5 6087 printed Jan 18, 2025@03:29:49 Page 2
- ORCMEDT5 ;SLC/MKB-Misc menu utilities ;03:29 PM 12 Feb 1999
- +1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**8,46,296,314,375**;Dec 17, 1997;Build 1
- SEARCH ; -- Search/replace menu items
- +1 NEW ORDLG
- +2 FOR
- SET ORDLG=$$DIC
- if ORDLG'>0
- QUIT
- DO SR1(ORDLG)
- WRITE !!
- +3 QUIT
- +4 ;
- SR1(ORX) ; -- list parents, get replacement
- +1 NEW CNT,DA,DR,DIE,DIK,I,J,ORDAD,ORY,ORNMBR,NUM,ORI,ORDAD,ORNM
- +2 IF '$ORDER(^ORD(101.41,"AD",+ORX,0))
- WRITE !,$PIECE(ORX,U,2)_" has no menu items."
- QUIT
- +3 WRITE @IOF,"Menu items of "_$PIECE(ORX,U,2),!?4,"Name",?69,"Type",!,$$REPEAT^XLFSTR("-",79)
- +4 SET (I,ORDAD)=0
- FOR
- SET I=$ORDER(^ORD(101.41,"AD",+ORX,I))
- if I'>0
- QUIT
- Begin DoDot:1
- +5 SET J=0
- FOR
- SET J=$ORDER(^ORD(101.41,"AD",+ORX,I,J))
- if J'>0
- QUIT
- Begin DoDot:2
- +6 SET ORDAD=ORDAD+1
- SET ORDAD(ORDAD)=I_U_J
- +7 WRITE !,ORDAD,?4,$PIECE(^ORD(101.41,I,0),U),?69,$$TYPE($PIECE(^(0),U,4))
- End DoDot:2
- End DoDot:1
- +8 WRITE !,$$REPEAT^XLFSTR("-",79)
- +9 SET ORY=$$REPLWITH(ORX)
- if ORY="^"
- QUIT
- +10 DO SELECT(ORY,ORDAD,.ORNMBR)
- if ORNMBR="^"
- QUIT
- +11 if '$$OK
- QUIT
- WRITE !!,$SELECT(ORY="@":"Removing",1:"Replacing "_$PIECE(ORX,U,2)_" with "_$PIECE(ORY,U,2))_" in:"
- +12 SET CNT=""
- FOR
- SET CNT=$ORDER(ORNMBR(CNT))
- if CNT=""
- QUIT
- Begin DoDot:1
- +13 DO LOOP($GET(ORNMBR(CNT)))
- End DoDot:1
- +14 QUIT
- LOOP(ORNMBR) ;
- +1 FOR ORI=1:1:$LENGTH(ORNMBR,",")
- SET NUM=$PIECE(ORNMBR,",",ORI)
- IF NUM
- Begin DoDot:1
- +2 SET DA(1)=+ORDAD(NUM)
- SET DA=$PIECE(ORDAD(NUM),U,2)
- SET DIE="^ORD(101.41,"_DA(1)_",10,"
- +3 SET ORDAD=DA(1)
- SET ORNM=$PIECE(^ORD(101.41,ORDAD,0),U)
- WRITE !?3,ORNM_" ..."
- +4 IF '$$VALID(ORY,ORDAD,.ORERR)
- Begin DoDot:2
- +5 WRITE "not "_$SELECT(ORY="@":"removed.",1:"changed."),!?3,">> "_$GET(ORERR)
- +6 SET I=0
- FOR
- SET I=$ORDER(ORERR(I))
- if I'>0
- QUIT
- WRITE !?25,"=>"_ORERR(I)
- End DoDot:2
- QUIT
- +7 IF ORY="@"
- SET DIK=DIE
- DO ^DIK
- WRITE "done."
- QUIT
- +8 SET DR="2////"_+ORY
- DO ^DIE
- WRITE $SELECT($PIECE(^ORD(101.41,DA(1),10,DA,0),U,2)=+ORY:"done.",1:"error - not replaced.")
- End DoDot:1
- +9 QUIT
- +10 ;
- TYPE(X) ; -- Returns name of dialog type
- +1 NEW Y
- SET Y=$SELECT(X="P":"prompt",X="D":"dialog",X="Q":"quick order",X="O":"order set",X="M":"menu",X="A":"action",1:"")
- +2 QUIT Y
- +3 ;
- DIC() ; -- ^DIC on Order Dialog file
- +1 NEW X,Y,DIC
- +2 SET DIC=101.41
- SET DIC(0)="AEQM"
- SET DIC("A")="Search for: "
- +3 SET DIC("?")="Enter the name of the dialog component you wish to search for."
- +4 DO ^DIC
- +5 QUIT Y
- +6 ;
- SELECT(ORY,MAX,Y) ; -- Select which Dlgs to replace items
- +1 NEW X,DIR
- +2 SET DIR(0)="LA^1:"_MAX
- SET DIR("A")=$SELECT(ORY="@":"Remove in: ",1:"Replace in: ")
- SET DIR("B")=$SELECT(MAX>1:"1-"_MAX,1:"1")
- +3 ; S DIR("?")
- +4 DO ^DIR
- if $DATA(DTOUT)!(X["^")
- SET Y="^"
- +5 QUIT
- +6 ;
- OK() ; -- Are you ready?
- +1 NEW X,Y,DIR
- +2 SET DIR(0)="YA"
- SET DIR("A")="Are you ready? "
- SET DIR("B")="NO"
- +3 WRITE !
- DO ^DIR
- +4 QUIT +Y
- +5 ;
- REPLWITH(ORIT) ; -- Remove item, or select replacement
- +1 NEW X,Y,DIR,DIC
- +2 SET DIR(0)="FAO^1:63"
- SET DIR("A")="Replace "_$PIECE(ORIT,U,2)_" with: "
- +3 SET DIR("?")="Enter the name of the item you wish to replace this one with, or @ to remove this item; to quit without changing anything, press <return>."
- R1 DO ^DIR
- IF X="@"
- QUIT "@"
- +1 IF $DATA(DTOUT)!("^"[X)
- QUIT "^"
- +2 SET DIC=101.41
- SET DIC(0)="EQM"
- DO ^DIC
- IF Y'>0
- GOTO R1
- +3 QUIT Y
- +4 ;
- VALID(ITM,DAD,ERR) ; -- Ck if ITM may be placed on DAD
- +1 NEW DTYPE,ITYPE,Y
- SET Y=0
- +2 SET DTYPE=$PIECE(^ORD(101.41,DAD,0),U,4)
- IF DTYPE="D"
- IF $$NMSP^ORCD($PIECE(^(0),U,7))'="OR"
- SET ERR="Only generic ordering dialogs are editable."
- GOTO VQ
- +3 ; ok to delete
- IF ITM="@"
- SET Y=1
- GOTO VQ
- +4 SET ITYPE=$PIECE(^ORD(101.41,+ITM,0),U,4)
- +5 IF ITYPE="P"
- IF DTYPE'="D"
- SET ERR="A prompt may not be added to a "_$$TYPE(DTYPE)_"."
- GOTO VQ
- +6 IF ITYPE="A"
- IF "DOM"'[DTYPE
- SET ERR="An action may not be added to a "_$$TYPE(DTYPE)_"."
- GOTO VQ
- +7 IF "DQOM"[ITYPE
- IF "OM"'[DTYPE
- SET ERR="A "_$$TYPE(ITYPE)_" may not be added to a "_$$TYPE(DTYPE)_"."
- GOTO VQ
- +8 DO RECURSV(+ITM,DAD,.ERR)
- IF $DATA(ERR)
- SET Y=0
- GOTO VQ
- +9 ; ok
- SET Y=1
- VQ QUIT Y
- +1 ;
- RECURSV(ITEM,MENU,MSG) ; -- Return 1 or 0, if recursive reference to ITEM
- +1 NEW STACK,CNT
- SET STACK=0
- SET CNT=0
- +2 KILL MSG
- +3 ;p375 prevents menu on itself
- IF ITEM=MENU
- SET MSG="Recursive Reference: "_$PIECE($GET(^ORD(101.41,ITEM,0)),U)
- QUIT
- +4 DO CHKPAR(MENU)
- +5 QUIT
- CHKPAR(MENU) ; follow tree to check parents
- +1 NEW PMENU,I
- +2 SET STACK=STACK+1
- SET STACK(STACK)=MENU
- SET STACK("B",MENU)=STACK
- SET PMENU=0
- +3 FOR
- SET PMENU=$ORDER(^ORD(101.41,"AD",MENU,PMENU))
- if 'PMENU
- QUIT
- Begin DoDot:1
- +4 IF PMENU=ITEM
- Begin DoDot:2
- +5 SET MSG="Recursive Reference: "_$PIECE(^ORD(101.41,ITEM,0),U)
- +6 FOR I=STACK:-1:1
- SET CNT=CNT+1
- SET MSG(CNT)=$PIECE(^ORD(101.41,STACK(I),0),U)
- End DoDot:2
- QUIT
- +7 IF $DATA(STACK("B",PMENU))
- QUIT
- +8 DO CHKPAR(PMENU)
- End DoDot:1
- if $DATA(MSG)
- QUIT
- +9 KILL STACK(STACK)
- SET STACK=STACK-1
- +10 QUIT
- +11 ;
- INUSE(MENU) ; -- Returns 1 or 0, if MENU is in use by parameter
- +1 NEW PARAM,ENT,Y
- +2 SET PARAM=$ORDER(^XTV(8989.51,"B","OR ADD ORDERS MENU",0))
- SET Y=0
- +3 SET ENT=""
- FOR
- SET ENT=$ORDER(^XTV(8989.5,"AC",PARAM,ENT))
- if ENT=""
- QUIT
- IF $GET(^(ENT,1))=MENU
- SET Y=1
- QUIT
- +4 QUIT Y
- +5 ;
- ASSIGN ; -- Assign menu to user(s)
- +1 DO FULL^VALM1
- +2 DO EDITPAR^XPAREDIT("OR ADD ORDERS MENU")
- +3 SET VALMBCK="R"
- +4 QUIT
- +5 ;
- INQ ; -- Inquire to Order Dialog file
- +1 NEW X,Y,DIC,DA,DR,DIQ
- +2 SET DIC="^ORD(101.41,"
- SET DIC(0)="AEQM"
- +3 FOR
- DO ^DIC
- if Y'>0
- QUIT
- SET DA=+Y
- WRITE !
- DO EN^DIQ
- WRITE !
- +4 QUIT
- +5 ;
- OUTPUT(ORY) ; -- Output Xform for Value field of Response multiple
- +1 NEW ORDIALOG,ORP,ORZ
- SET ORZ=ORY
- +2 SET ORP=$PIECE($GET(^ORD(101.41,D0,6,D1,0)),U,2)
- +3 IF ORP
- SET ORDIALOG(ORP,0)=$PIECE($GET(^ORD(101.41,ORP,1)),U,1,2)
- SET ORDIALOG(ORP,1)=ORY
- SET ORZ=$$EXT^ORCD(ORP,1)
- +4 QUIT ORZ
- +5 ;
- AOPAR ; -- List of add order menus assigned to users
- +1 NEW BY,DHD,DIC,FLDS,FR,TO
- +2 SET DIC=8989.5
- +3 SET FR="OR ADD ORDERS MENU,?"
- SET TO="OR ADD ORDERS MENU,?"
- +4 SET BY="@.02,@1;S2;""Add order menu: """
- +5 SET DHD="CPRS Add order menu list"
- +6 SET FLDS="VALUE;N;""Menu"",ENTITY;""User/Location/etc."";C40"
- +7 DO EN1^DIP
- +8 QUIT
- +9 ;
- DISABLE ; -- Disable order dialogs
- +1 NEW X,Y,DIC,DIR,ORDIS,ORI
- KILL ^TMP("ORDISABLE",$JOB)
- +2 SET DIC=101.41
- SET DIC(0)="AEQM"
- SET DIC("A")="Select ORDER DIALOG: "
- SET DIC("?")="Enter the name of an order dialog you wish to disable."
- +3 SET DIC("W")="I $L($P(^(0),U,3)) W !?3,"">> disabled: ""_$P(^(0),U,3)"
- +4 FOR
- DO ^DIC
- if Y'>0
- QUIT
- SET ^TMP("ORDISABLE",$JOB,+Y)=""
- SET DIC("A")="ANOTHER ONE: "
- +5 ;none selected
- if '$ORDER(^TMP("ORDISABLE",$JOB,0))
- QUIT
- +6 WRITE !!,"Enter a message to disable the dialog(s), or @ to enable again."
- +7 SET DIR(0)="FAO^1:40"
- SET DIR("A")="MESSAGE: "
- +8 SET DIR("?")="Enter up to 40 characters explaining why use of this dialog has been disabled that will display if the dialog is selected, or @ to enable the dialog again."
- +9 DO ^DIR
- if $DATA(DTOUT)!$DATA(DUOUT)!(X="")
- GOTO DQ
- SET ORDIS=X
- +10 IF '$$OK
- WRITE !,"Nothing "_$SELECT(ORDIS="@":"en",1:"dis")_"abled."
- HANG 1
- GOTO DQ
- +11 SET ORI=0
- FOR
- SET ORI=$ORDER(^TMP("ORDISABLE",$JOB,ORI))
- if ORI'>0
- QUIT
- SET $PIECE(^ORD(101.41,ORI,0),U,3)=$SELECT(ORDIS="@":"",1:ORDIS)
- WRITE "."
- +12 WRITE !,"done."
- HANG 1
- DQ KILL ^TMP("ORDISABLE",$JOB)
- +1 QUIT