ORY4 ;SLB/MKB-postinit for OR*3.0*4 ;4/30/98 15:52
;;3.0;ORDER ENTRY/RESULTS REPORTING;**4**;Dec 17, 1997
;
EN ; -- check orderables, dialogs, display groups
N DA,DIK S DIK="^DD(101.416,",DA(1)=101.416,DA=.04 D ^DIK
D OI^ORSETUP1 ; reset orderables pointers in quick orders
D DLG ; fix DG,SD,SR dialogs
N ORSEQ,ORX
F ORSEQ=1:1 S ORX=$T(DG+ORSEQ) Q:ORX["ZZZZZ" D ADD ; add new groups
Q
;
ADD ; -- add new group to file, to LAB as member
N X,Y,DA,DIC,DR,DIE,DLAYGO
S DIC="^ORD(100.98,",DIC(0)="LX",DLAYGO=100.98,DIE=DIC
S Y=+$O(^ORD(100.98,"B",$P(ORX,";",5),0))
I Y'>0 S X=$P(ORX,";",3) D ^DIC Q:Y'>0 ; error msg??
S DA=+Y,DR=".01///"_$P(ORX,";",3)_";2///"_$P(ORX,";",4)_";3///"_$P(ORX,";",5) D ^DIE
K X,Y,DA S DA(1)=+$O(^ORD(100.98,"B","LAB",0)) Q:'DA(1)
S DIC="^ORD(100.98,"_DA(1)_",1,",X=$P(ORX,";",5) D ^DIC
Q
;
DG ;;NAME;Mixed Name;SHORT NAME
;;ELECTRON MICROSCOPY;Electron Microscopy;EM
;;SURGICAL PATHOLOGY;Surg. Path.;SP
;;AUTOPSY;Autopsy;AU
;;CYTOLOGY;Cytology;CY
;;ZZZZZ
;
DLG ; -- add save/restore calls to DG,SD,SR dialogs
N X,ORPKG,ORDLG,ENTRY,EXIT S ORDLG=0
F X="DG","SD","SR" S X=$O(^DIC(9.4,"C",X,0)) S:X ORPKG(X)=""
F S ORDLG=$O(^ORD(101.41,ORDLG)) Q:ORDLG'>0 S X=+$P($G(^(ORDLG,0)),U,7) I $D(ORPKG(X)) D
. S ENTRY=$G(^ORD(101.41,ORDLG,3)),EXIT=$G(^(4))
. S:ENTRY'["SAVE^ORXD" ENTRY="D SAVE^ORXD"_$S($L(ENTRY):" "_ENTRY,1:"")
. S:EXIT="D REBLD^ORCMENU" EXIT=""
. I $L(EXIT),EXIT["REBLD^ORCMENU" S EXIT=$P(EXIT," D REBLD^ORCMENU")
. S:EXIT'["RSTR^ORXD" EXIT=EXIT_$S($L(EXIT):" ",1:"")_"D RSTR^ORXD"
. S ^ORD(101.41,ORDLG,3)=ENTRY,^(4)=EXIT
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORY4 1642 printed Sep 23, 2025@20:18:05 Page 2
ORY4 ;SLB/MKB-postinit for OR*3.0*4 ;4/30/98 15:52
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**4**;Dec 17, 1997
+2 ;
EN ; -- check orderables, dialogs, display groups
+1 NEW DA,DIK
SET DIK="^DD(101.416,"
SET DA(1)=101.416
SET DA=.04
DO ^DIK
+2 ; reset orderables pointers in quick orders
DO OI^ORSETUP1
+3 ; fix DG,SD,SR dialogs
DO DLG
+4 NEW ORSEQ,ORX
+5 ; add new groups
FOR ORSEQ=1:1
SET ORX=$TEXT(DG+ORSEQ)
if ORX["ZZZZZ"
QUIT
DO ADD
+6 QUIT
+7 ;
ADD ; -- add new group to file, to LAB as member
+1 NEW X,Y,DA,DIC,DR,DIE,DLAYGO
+2 SET DIC="^ORD(100.98,"
SET DIC(0)="LX"
SET DLAYGO=100.98
SET DIE=DIC
+3 SET Y=+$ORDER(^ORD(100.98,"B",$PIECE(ORX,";",5),0))
+4 ; error msg??
IF Y'>0
SET X=$PIECE(ORX,";",3)
DO ^DIC
if Y'>0
QUIT
+5 SET DA=+Y
SET DR=".01///"_$PIECE(ORX,";",3)_";2///"_$PIECE(ORX,";",4)_";3///"_$PIECE(ORX,";",5)
DO ^DIE
+6 KILL X,Y,DA
SET DA(1)=+$ORDER(^ORD(100.98,"B","LAB",0))
if 'DA(1)
QUIT
+7 SET DIC="^ORD(100.98,"_DA(1)_",1,"
SET X=$PIECE(ORX,";",5)
DO ^DIC
+8 QUIT
+9 ;
DG ;;NAME;Mixed Name;SHORT NAME
+1 ;;ELECTRON MICROSCOPY;Electron Microscopy;EM
+2 ;;SURGICAL PATHOLOGY;Surg. Path.;SP
+3 ;;AUTOPSY;Autopsy;AU
+4 ;;CYTOLOGY;Cytology;CY
+5 ;;ZZZZZ
+6 ;
DLG ; -- add save/restore calls to DG,SD,SR dialogs
+1 NEW X,ORPKG,ORDLG,ENTRY,EXIT
SET ORDLG=0
+2 FOR X="DG","SD","SR"
SET X=$ORDER(^DIC(9.4,"C",X,0))
if X
SET ORPKG(X)=""
+3 FOR
SET ORDLG=$ORDER(^ORD(101.41,ORDLG))
if ORDLG'>0
QUIT
SET X=+$PIECE($GET(^(ORDLG,0)),U,7)
IF $DATA(ORPKG(X))
Begin DoDot:1
+4 SET ENTRY=$GET(^ORD(101.41,ORDLG,3))
SET EXIT=$GET(^(4))
+5 if ENTRY'["SAVE^ORXD"
SET ENTRY="D SAVE^ORXD"_$SELECT($LENGTH(ENTRY):" "_ENTRY,1:"")
+6 if EXIT="D REBLD^ORCMENU"
SET EXIT=""
+7 IF $LENGTH(EXIT)
IF EXIT["REBLD^ORCMENU"
SET EXIT=$PIECE(EXIT," D REBLD^ORCMENU")
+8 if EXIT'["RSTR^ORXD"
SET EXIT=EXIT_$SELECT($LENGTH(EXIT):" ",1:"")_"D RSTR^ORXD"
+9 SET ^ORD(101.41,ORDLG,3)=ENTRY
SET ^(4)=EXIT
End DoDot:1
+10 QUIT
