- 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 Feb 19, 2025@00:08:17 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
