Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ORCMEDT3

ORCMEDT3.m

Go to the documentation of this file.
  1. ORCMEDT3 ;SLC/MKB-Dialog editor ;Apr 21, 2021@13:21
  1. ;;3.0;ORDER ENTRY/RESULTS REPORTING;**8,46,60,95,556,567**;Dec 17, 1997;Build 1
  1. ;
  1. EN ; -- Enter/edit generic ordering dialog
  1. N ORDLG,ORDG
  1. F S ORDLG=$$DIALOG^ORCMEDT0("D") Q:ORDLG="^" D EN1(ORDLG) W !
  1. Q
  1. EN1(ORDLG) ; -- edit dialog ORDLG
  1. N ORPROG,X,Y,D,DA,DR,DIE,DIC,OR0,ORP,ORTYPE,ORDOM,ORQUIT,ORNAME,ORPKG
  1. Q:'$G(ORDLG) S ORPROG=(DUZ(0)="@"),DA=ORDLG,DIE="^ORD(101.41,",DR=""
  1. S ORPKG=+$P($G(^ORD(101.41,ORDLG,0)),U,7),ORPKG=$S($O(^DIC(9.4,"C","OR",0))=ORPKG:1,1:0) ;1 or 0, if PKG=OR
  1. I ORPKG S ORNAME=$$NAME^ORCMEDT4(ORDLG) Q:(ORNAME="@")!(ORNAME="^") S DR=".01///^S X=ORNAME;" ; Name not editable for pkg dialogs
  1. S DR=DR_"2;6;8;9"_$S('ORPKG:"",ORPROG:";20;30;40;17;19",1:";20")
  1. D ^DIE Q:$D(DTOUT)!$D(Y) Q:'$G(DA) ; deleted
  1. D DGRP Q:ORDG="^" ;edit display group
  1. EN11 S ORQUIT=0 F D Q:ORQUIT W ! ; ** Only few fields editable if pkg dlg
  1. . S DIC="^ORD(101.41,"_ORDLG_",10,",DIC(0)="AEQM"_$S(ORPKG:"L",1:"")
  1. . S DIC("A")="Select PROMPT: ",DIC("P")=$P(^DD(101.41,10,0),U,2),D="B^D"
  1. . S DIC("DR")="21///"_(+$O(^ORD(101.41,ORDLG,10,"ATXT","A"),-1)+1)
  1. . K DA S DA(1)=ORDLG D MIX^DIC1 I Y'>0 S ORQUIT=1 Q
  1. . S DA=+Y,DIE=DIC,DR=.01 I ORPKG D ^DIE Q:'$G(DA)!$D(DTOUT)!$D(Y)
  1. . S OR0=$G(^ORD(101.41,DA(1),10,DA,0)),ORP=$S(ORPKG:$$PROMPT($P(OR0,U,2)),1:$P(OR0,U,2))
  1. . I ORP="^" S DIK=DIC D:'$P(OR0,U,2) ^DIK Q ;delete item if no prompt
  1. . S ORTYPE=$P(^ORD(101.41,ORP,1),U),ORDOM=$P(^(1),U,2)
  1. . I ORP'=$P(OR0,U,2),ORTYPE'=$P($G(^ORD(101.41,+$P(OR0,U,2),1)),U) D
  1. . . N I F I=.1,4,7,8 K ^ORD(101.41,ORDLG,10,DA,I) ;kill xform,screen,def
  1. . . S $P(^ORD(101.41,ORDLG,10,DA,0),U,10)="",$P(^(1),U,2)="" ;index,lkup
  1. . S DR=$S(ORPKG:"2////"_ORP_$S(ORTYPE="P"&ORPROG:";10;14;12",1:"")_";4;6;7;I 'X S Y=""@1"";7.1;7.2;7.3;S Y=8;@1;7.1///@;7.2///@;7.3///@;8;9;11",1:"8;9") D ^DIE Q:$D(DTOUT)!$D(Y)
  1. . I 'ORPROG K DIRUT D DEFAULT Q:$G(DIRUT)
  1. . I ORPROG S DR=$S(ORPKG:"16;13;.1;",1:"")_$S(ORTYPE="W":18,1:17)_$S(ORPKG:";15;19;20",1:"") D ^DIE Q:$D(DTOUT)!$D(Y)
  1. . S DR="21;I X'>0 S Y=0;22:"_$S(ORTYPE="W":"27",1:"26") D ^DIE
  1. D WINID,AUTO^ORCMEDT1(ORDLG),TRY(ORDLG) ;Auto-Accept flag, test changes
  1. Q
  1. ;
  1. PROMPT(X) ; -- Enter/edit prompt
  1. ;OR*3.0*556 - check for same ID on multiple prompts
  1. N ORXPR,ORXSUB,ORXID,ORXIDAR
  1. S ORXPR=0
  1. F S ORXPR=$O(^ORD(101.41,ORDLG,10,ORXPR)) Q:'ORXPR D
  1. . S ORXSUB=$P($G(^ORD(101.41,ORDLG,10,ORXPR,0)),"^",2)
  1. . Q:ORXSUB=""
  1. . S ORXID=$P($G(^ORD(101.41,ORXSUB,1)),"^",3)
  1. . I ORXID]"" S ORXIDAR(ORXID)=$P(^ORD(101.41,ORDLG,10,ORXPR,0),"^")_" ("_$P(^ORD(101.41,ORXSUB,0),"^")_")"
  1. ;end OR*3.0*556
  1. N Y,DIC,OLD S OLD=+$G(X)
  1. S DIC="^ORD(101.41,",DIC(0)="AEQM",DIC("S")="I $P(^(0),U,4)=""P"""
  1. S DIC("A")="PROMPT: " S:OLD DIC("B")=$P(^ORD(101.41,X,0),U)
  1. S DIC("W")="W "" ""_$$TYPE^ORCMEDT3($P($G(^(1)),U))" ; show type
  1. P1 D ^DIC I $D(DTOUT)!$D(DUOUT) S Y="^" G PQ
  1. I Y'>0 W $C(7),!?5,"This is a required field!" G P1
  1. I +Y'=OLD,$D(^ORD(101.41,ORDLG,10,"D",+Y)) W $C(7),!?5,"Duplicates are not allowed!" G P1
  1. ;OR*3.0*556 begin
  1. S ORXID=$P($G(^ORD(101.41,+Y,1)),"^",3)
  1. ;OR*3.0*567: added the check for variable "OLD" so that
  1. ; existing prompts may be edited.
  1. I 'OLD,ORXID]"",$D(ORXIDAR(ORXID)) D G P1
  1. . W $C(7),!!,?5,"Sequence ",ORXIDAR(ORXID)," is also"
  1. . W !,?5,"defined with an ID of ",ORXID,"."
  1. . W !!,?5,"Select another prompt or define a new prompt"
  1. . W !,?5,"with a different ID."
  1. . W !!,?5,"WARNING: Do not change the ID field on an existing"
  1. . W !,?5," prompt so as to not affect order dialogs"
  1. . W !,?5," already using the existing prompt."
  1. . W !,?5," (The ID field can only be edited in the option"
  1. . W !,?5," ""Enter/edit prompts"" - not this option.)"
  1. I ORXID]"" S ORXIDAR(ORXID)=OR0_" ("_$P(^ORD(101.41,+Y,0),"^")_")"
  1. ;end OR*3.0*556
  1. S Y=+Y
  1. PQ Q Y
  1. ;
  1. TYPE(X) ; -- Displays datatype and domain as identifiers
  1. I '$L($G(X)) Q ""
  1. N Y S Y=$S(X="D":"date/time",X="R":"relative date/time",X="F":"free text",X="N":"numeric",X="S":"set of codes",X="P":"pointer to a file",X="Y":"yes/no",X="W":"word processing",1:"")
  1. Q Y
  1. ;
  1. DEFAULT ; -- Enter/edit default value
  1. G:ORTYPE="W" WP N OLD,X,Y,D,DIC,DIR,%DT,ORDIC,ORSCR
  1. S:$D(^ORD(101.41,ORDLG,10,DA,4)) ORSCR=^(4)
  1. S OLD=$G(^ORD(101.41,ORDLG,10,DA,7)) I $L(OLD) D Q:OLD="^"
  1. . S OLD=$$VALUE(OLD) S:"^P^D^R^"[(U_ORTYPE_U)&(OLD=-1) OLD=""
  1. . I OLD="^" W !,"DEFAULT: <executable code - uneditable>//" Q
  1. S DIR("A")="DEFAULT: ",DIR(0)=$S(ORTYPE="P":"FAO^1:63",ORTYPE="D"!(ORTYPE="R"):"DAO^"_ORDOM,1:ORTYPE_"AO^"_ORDOM)
  1. S:$L(OLD) DIR("B")=$S(ORTYPE="P":$$GET1^DIQ(+ORDOM,+OLD_",",.01),ORTYPE="D":$$FMTE^XLFDT(OLD),1:OLD)
  1. S:ORTYPE="P" DIR("?")="Select an entry from the file; enter ?? to see a list of choices",DIR("??")="^D LIST^ORCMEDT3"
  1. DF1 D ^DIR K DIRUT I $D(DTOUT)!(X["^") S DIRUT=1 Q
  1. Q:X="" Q:X=$G(DIR("B")) ; no value or no change
  1. I X="@" K ^ORD(101.41,ORDLG,10,DA,7) Q
  1. I ORTYPE="R" S Y=X
  1. I ORTYPE="P" D G:Y'>0 DF1
  1. . S DIC=$S(+ORDOM:+ORDOM,1:U_$P(ORDOM,":"))
  1. . S DIC(0)="EQ",D=$P(OR0,U,10),ORDIC="^DIC"
  1. . S:$D(ORSCR) DIC("S")=ORSCR
  1. . I $L(D) S D=$TR(D,";","^"),ORDIC=$S($L(D,"^")>1:"MIX^DIC1",1:"IX^DIC")
  1. . D @ORDIC S Y=$P(Y,U)
  1. DFQ S ^ORD(101.41,ORDLG,10,DA,7)=$S(Y'="":"S Y="""_Y_"""",1:"Q")
  1. Q
  1. ;
  1. VALUE(CODE) ; -- Returns value following "S Y="
  1. N I,X,Y,Z S Z=$F(CODE,"S Y=") I 'Z Q "^"
  1. S X=$E(CODE,Z,999),Y="" I '+X,$E(X)'="""" Q "^" ;not numeric or literal
  1. S:$E(X)="""" X=$E(X,2,999)
  1. F I=1:1:$L(X) S Z=$E(X,I) Q:(Z="""") S Y=Y_Z
  1. Q Y
  1. ;
  1. LIST ; -- ??help for ptrs
  1. N D,DIC,DZ
  1. S DIC=$S(+ORDOM:$$ROOT^DILFD(+ORDOM),1:U_$P(ORDOM,":"))
  1. S DIC(0)="EQS",DZ="??",D=$P(OR0,U,10) S:'$L(D) D="B"
  1. S:$D(ORSCR) DIC("S")=ORSCR
  1. D DQ^DICQ
  1. Q
  1. ;
  1. WP ; -- Enter/edit WP data
  1. N DIC,DIWESUB W !,"DEFAULT: "
  1. S DIC="^ORD(101.41,"_ORDLG_",10,"_DA_",8,",DIWESUB="DEFAULT"
  1. D EN^DIWE
  1. Q
  1. ;
  1. DGRP ; -- Edit display group [and orderable item]
  1. N X,Y,DA,DR,DIE,OI,IDX
  1. S DA=ORDLG,DR="5R",DIE="^ORD(101.41," D ^DIE I $D(Y) S ORDG="^" Q
  1. Q:$P($G(^ORD(101.41,ORDLG,0)),U,5)=ORDG S ORDG=$P(^(0),U,5)
  1. S OI=$O(^ORD(101.41,ORDLG,10,"D",+$$PTR^ORCD("OR GTX ORDERABLE ITEM"),0)) Q:'OI
  1. S IDX="S."_$P($G(^ORD(100.98,ORDG,0)),U,3)
  1. S $P(^ORD(101.41,ORDLG,10,OI,0),U,10)=IDX K ^(7)
  1. W !," >> You must select a new orderable item from this group."
  1. Q
  1. ;
  1. OI(ORDG) ; -- Returns OI for generic dialog
  1. Q:'$G(ORDG) "" N X,Y,D,DIC,DLAYGO,DA,DR,DIE,ID,ORDIC,ORY
  1. S D=$P($G(^ORD(100.98,+ORDG,0)),U,3)
  1. I "^ANI^AP^AU^BB^CARD^CH^CSLT^CT^CY^D AO^D CON^DIET^DO^E/L T^EM^HEMA^I RX^IV RX^LAB^MAM^MI^MRI^NM^O RX^PREC^PROC^RAD^RX^SP^SPLY^TF^TPN^UD RX^US^VAS^XRAY^"'[(U_D_U) S ORADD=1 ;95 Only add OI if generic DG
  1. S DIC=101.43,DIC(0)="AEQ"_$S($G(ORADD):"L",1:""),ORDIC="^DIC",DIE=DIC S:$G(ORADD) DLAYGO=101.43 ;95
  1. S DIC("A")=" ORDERABLE ITEM: " S:$L(D) D="S."_D,ORDIC="IX^DIC"
  1. D @ORDIC S ORY=Y S:Y'>0 Y=$S(X["^":"^",$D(DTOUT):"^",1:""),ORY=Y
  1. I Y,$P(Y,U,3) S DA=+Y,ID=DA_";99ORD",DR="2///^S X=ID;5////"_+ORDG D ^DIE
  1. Q ORY
  1. ;
  1. TRY(ORDIALOG) ; -- Test [new] dialog
  1. N X,Y,DIR,FIRST,ORTYPE,ORNMSP,ORVP,ORL,ORNP,AUTO W !
  1. S DIR(0)="YA",DIR("A")="Do you want to test this dialog now? "
  1. D ^DIR Q:Y'>0 W ! D GETDLG^ORCD(ORDIALOG)
  1. S ORTYPE="D",ORNMSP="OR",FIRST=1,(ORVP,ORL,ORNP)=0
  1. S AUTO=$P($G(^ORD(101.41,ORDIALOG,5)),U,8)
  1. X:$D(^ORD(101.41,ORDIALOG,3.1)) ^(3.1) ;editor entry action
  1. D DIALOG^ORCDLG,DISPLAY^ORCDLG
  1. X:$D(^ORD(101.41,ORDIALOG,4)) ^(4) ;dlg exit action
  1. Q
  1. ;
  1. WINID ; -- Need to clear Window ID for GUI? [from EN]
  1. Q:'ORPKG Q:'$P($G(^ORD(101.41,ORDLG,5)),U,5) ;already cleared
  1. ; ck prompts to see if they match OR GXMISC GENERAL
  1. N ORGXMISC,ORX,ORP,ORQUIT
  1. F ORX="ORDERABLE ITEM","FREE TEXT 1","START DATE/TIME","STOP DATE/TIME" S ORP=+$O(^ORD(101.41,"AB","OR GTX "_ORX,0)) I ORP S ORGXMISC(ORP)="" I '$O(^ORD(101.41,ORDLG,10,"D",ORP,0)) S ORQUIT=1 Q
  1. I '$G(ORQUIT) S ORP=0 F S ORP=$O(^ORD(101.41,ORDLG,10,"D",ORP)) Q:ORP'>0 I '$D(ORGXMISC(ORP)) S ORQUIT=1 Q
  1. S:$G(ORQUIT) $P(^ORD(101.41,ORDLG,5),U,5)="" ;clear ID
  1. Q
  1. ;
  1. ACTION ; -- Enter/edit actions
  1. N DA,DR,DIE,ORNAME S DIE="^ORD(101.41,"
  1. F S DA=$$DIALOG^ORCMEDT0("A") Q:DA="^" D W !
  1. . S ORNAME=$$NAME^ORCMEDT4(DA) Q:(ORNAME="@")!(ORNAME="^")
  1. . S DR=".01///^S X=ORNAME;2;"_$S(DUZ(0)="@":"30;40;",1:"")_"20" D ^DIE
  1. Q