ORY4.m

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

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