ORY142 ; SLC/MKB - inits for ED pre-patch OR*3*142 ;7/3/02 13:57
;;3.0;ORDER ENTRY/RESULTS REPORTING;**142**;Dec 17, 1997
;DBIA reference section
;2263 - XPAR
;2058 - ^DIC(9.4,"C"
;10013- DIK
;10014- DIU2
;10112- VASITE
;10103- XLFDT
;
PRE ; -- preinit
I '$O(^ORD(101.41,"AB","OR GTX EVENT",0)) D ;1st install
. N DIU ;remove old 100.5, 100.6 DD's
. F DIU="^ORYX(""ORTO"",","^ORYX(""ORPAR""," S DIU(0)="DST" D EN^DIU2
Q
;
DLGSEND(X) ; -- Return true if the order dialog should be sent
I X="OR GTX EVENT" Q 1
I X="OR GXMOVE EVENT" Q 1
Q 0
;
DCSEND(X) ; -- Return true if order reason should be sent
I X="ORDEATH" Q 1
I X="OROR" Q 1
I X="ORPASS" Q 1
I X="ORASIH" Q 1
Q 0
;
PRMSEND(X) ; -- Return true if parameter definition should be sent
I X="ORWDX WRITE ORDERS EVENT LIST" Q 1
I X="OREVNT DEFAULT" Q 1
Q 0
;
POST ; -- postinit to convert old DC parameters to file #100.6
; Creates a set of rules for [primary] division
;
Q:$O(^ORD(100.6,0)) ;not 1st install
N ORI,ORADMIT,ORDIS,ORTRANS,ORSPEC,ORDEATH,OROR,ORPASS,ORASIH,ORPARM,ORNOW,ORDIV,ORPKG,DIK,ORGLOB,I
F ORI="ORADMIT","ORDIS","ORTRANS","ORSPEC","ORDEATH","OROR","ORPASS","ORASIH" S @ORI=+$O(^ORD(100.03,"C",ORI,0))
D GETLST^XPAR(.ORPARM,"ALL","OR DC ON SPEC CHANGE")
S ORPARM("T")=$$GET^XPAR("ALL","ORPF DC OF GENERIC ORDERS")
S ORPARM("A")=$$GET^XPAR("ALL","OR DC GEN ORD ON ADMISSION")
S ORI=0,ORNOW=+$$NOW^XLFDT,ORDIV=+$$SITE^VASITE Q:ORDIV<1
P1 ; -- ADMISSION rule
S ORI=ORI+1,^ORD(100.6,ORI,0)="ADMISSION^A^"_ORDIV_U_ORADMIT_"^ADMISSION"
D MVTYPES(ORI,"8^9^15^18^28^29^30^36^39")
S ORPKG=1,ORPKG(1)=+$O(^DIC(9.4,"C","OR",0))_"^1" D PKGS(ORI,.ORPKG)
I ORPARM("A")<1 S ^ORD(100.6,ORI,1)=ORNOW ;inactive
E S ^ORD(100.6,ORI,2,0)="^100.61DA^1^1",^(1,0)=ORNOW
P2 ; -- SPECIALTY CHANGE rule
S ORI=ORI+1,^ORD(100.6,ORI,0)="SPECIALTY CHANGE^S^"_ORDIV_U_ORSPEC_"^SPECIALTY CHANGE"
D MVTYPES(ORI,"20"),PKGS(ORI,.ORPARM)
I ORPARM<1 S ^ORD(100.6,ORI,1)=ORNOW ;inactive
E S ^ORD(100.6,ORI,2,0)="^100.61DA^1^1",^(1,0)=ORNOW
P3 ; -- WARD TRANSFER rule
S ORI=ORI+1,^ORD(100.6,ORI,0)="WARD TRANSFER^T^"_ORDIV_U_ORTRANS_"^WARD TRANSFER"
D MVTYPES(ORI,"4")
S ORPKG=1,ORPKG(1)=+$O(^DIC(9.4,"C","OR",0))_"^1" D PKGS(ORI,.ORPKG)
I ORPARM("T")<1 S ^ORD(100.6,ORI,1)=ORNOW ;inactive
E S ^ORD(100.6,ORI,2,0)="^100.61DA^1^1",^(1,0)=ORNOW
P4 ; -- DISCHARGE rule
S ORI=ORI+1,^ORD(100.6,ORI,0)="DISCHARGE^D^"_ORDIV_U_ORDIS_"^DISCHARGE"
D MVTYPES(ORI,"10^11^16^17^21^27^31^32^33^34^35^37^42^46^47")
F I="1^OR","2^FH" S ORPKG(+I)=+$O(^DIC(9.4,"C",$P(I,U,2),0))_"^1"
S ORPKG=2 D PKGS(ORI,.ORPKG)
S ^ORD(100.6,ORI,2,0)="^100.61DA^1^1",^(1,0)=ORNOW ;active
P5 ; -- DEATH rule
S ORI=ORI+1,^ORD(100.6,ORI,0)="DEATH^D^"_ORDIV_U_ORDEATH_"^DEATH"
S ORPKG=4 F I="1^OR","2^FH","3^GMRC","4^RA" S ORPKG(+I)=+$O(^DIC(9.4,"C",$P(I,U,2),0))_"^1"
D PKGS(ORI,.ORPKG),MVTYPES(ORI,"12^38")
S ^ORD(100.6,ORI,2,0)="^100.61DA^1^1",^(1,0)=ORNOW ;active
; ** Create the following but leave inactive for now:
P6 ; -- OR rule
S ORI=ORI+1,^ORD(100.6,ORI,0)="SURGERY^O^"_ORDIV_U_OROR_"^SURGERY"
S ORPKG=1,ORPKG(1)=+$O(^DIC(9.4,"C","OR",0))_"^1" D PKGS(ORI,.ORPKG)
S ^ORD(100.6,ORI,1)=ORNOW
P7 ; -- ON PASS rule
S ORI=ORI+1,^ORD(100.6,ORI,0)="ON PASS^T^"_ORDIV_U_ORPASS_"^ON PASS"
D MVTYPES(ORI,"1^2^3") S ^ORD(100.6,ORI,1)=ORNOW
P8 ; -- FROM PASS rule
S ORI=ORI+1,^ORD(100.6,ORI,0)="FROM PASS^T^"_ORDIV_U_ORPASS_"^FROM PASS"
D MVTYPES(ORI,"22^23^24^25^26") S ^ORD(100.6,ORI,1)=ORNOW
P9 ; -- TO ASIH rule
S ORI=ORI+1,^ORD(100.6,ORI,0)="TO ASIH^T^"_ORDIV_U_ORASIH_"^TO ASIH"
D MVTYPES(ORI,"13") S ^ORD(100.6,ORI,1)=ORNOW
P10 ; -- FROM ASIH rule
S ORI=ORI+1,^ORD(100.6,ORI,0)="FROM ASIH^T^"_ORDIV_U_ORASIH_"^FROM ASIH"
D MVTYPES(ORI,"14") S ^ORD(100.6,ORI,1)=ORNOW
S $P(^ORD(100.6,0),U,3,4)=ORI_U_ORI
S DIK="^ORD(100.6," D IXALL^DIK ;set xrefs
;Set edit history for new rules
S ORGLOB="^ORD(100.6,"
S ORI=0 F S ORI=$O(^ORD(100.6,ORI)) Q:'+ORI D AUDIT^OREV(ORI,"N")
Q
;
MVTYPES(IEN,TYPES) ; -- save MAS Movement Types
N CNT,I S CNT=$L(TYPES,U)
S ^ORD(100.6,IEN,3,0)="^100.63P^"_CNT_U_CNT
F I=1:1:CNT S ^ORD(100.6,IEN,3,I,0)=+$P(TYPES,U,I)
Q
;
PKGS(IEN,PKGS) ; -- save Included Packages
N CNT,I S CNT=+$G(PKGS)
S ^ORD(100.6,IEN,7,0)="^100.67P^"_CNT_U_CNT
F I=1:1:CNT S ^ORD(100.6,IEN,7,I,0)=+PKGS(I)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORY142 4420 printed Nov 22, 2024@17:48:27 Page 2
ORY142 ; SLC/MKB - inits for ED pre-patch OR*3*142 ;7/3/02 13:57
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**142**;Dec 17, 1997
+2 ;DBIA reference section
+3 ;2263 - XPAR
+4 ;2058 - ^DIC(9.4,"C"
+5 ;10013- DIK
+6 ;10014- DIU2
+7 ;10112- VASITE
+8 ;10103- XLFDT
+9 ;
PRE ; -- preinit
+1 ;1st install
IF '$ORDER(^ORD(101.41,"AB","OR GTX EVENT",0))
Begin DoDot:1
+2 ;remove old 100.5, 100.6 DD's
NEW DIU
+3 FOR DIU="^ORYX(""ORTO"",","^ORYX(""ORPAR"","
SET DIU(0)="DST"
DO EN^DIU2
End DoDot:1
+4 QUIT
+5 ;
DLGSEND(X) ; -- Return true if the order dialog should be sent
+1 IF X="OR GTX EVENT"
QUIT 1
+2 IF X="OR GXMOVE EVENT"
QUIT 1
+3 QUIT 0
+4 ;
DCSEND(X) ; -- Return true if order reason should be sent
+1 IF X="ORDEATH"
QUIT 1
+2 IF X="OROR"
QUIT 1
+3 IF X="ORPASS"
QUIT 1
+4 IF X="ORASIH"
QUIT 1
+5 QUIT 0
+6 ;
PRMSEND(X) ; -- Return true if parameter definition should be sent
+1 IF X="ORWDX WRITE ORDERS EVENT LIST"
QUIT 1
+2 IF X="OREVNT DEFAULT"
QUIT 1
+3 QUIT 0
+4 ;
POST ; -- postinit to convert old DC parameters to file #100.6
+1 ; Creates a set of rules for [primary] division
+2 ;
+3 ;not 1st install
if $ORDER(^ORD(100.6,0))
QUIT
+4 NEW ORI,ORADMIT,ORDIS,ORTRANS,ORSPEC,ORDEATH,OROR,ORPASS,ORASIH,ORPARM,ORNOW,ORDIV,ORPKG,DIK,ORGLOB,I
+5 FOR ORI="ORADMIT","ORDIS","ORTRANS","ORSPEC","ORDEATH","OROR","ORPASS","ORASIH"
SET @ORI=+$ORDER(^ORD(100.03,"C",ORI,0))
+6 DO GETLST^XPAR(.ORPARM,"ALL","OR DC ON SPEC CHANGE")
+7 SET ORPARM("T")=$$GET^XPAR("ALL","ORPF DC OF GENERIC ORDERS")
+8 SET ORPARM("A")=$$GET^XPAR("ALL","OR DC GEN ORD ON ADMISSION")
+9 SET ORI=0
SET ORNOW=+$$NOW^XLFDT
SET ORDIV=+$$SITE^VASITE
if ORDIV<1
QUIT
P1 ; -- ADMISSION rule
+1 SET ORI=ORI+1
SET ^ORD(100.6,ORI,0)="ADMISSION^A^"_ORDIV_U_ORADMIT_"^ADMISSION"
+2 DO MVTYPES(ORI,"8^9^15^18^28^29^30^36^39")
+3 SET ORPKG=1
SET ORPKG(1)=+$ORDER(^DIC(9.4,"C","OR",0))_"^1"
DO PKGS(ORI,.ORPKG)
+4 ;inactive
IF ORPARM("A")<1
SET ^ORD(100.6,ORI,1)=ORNOW
+5 IF '$TEST
SET ^ORD(100.6,ORI,2,0)="^100.61DA^1^1"
SET ^(1,0)=ORNOW
P2 ; -- SPECIALTY CHANGE rule
+1 SET ORI=ORI+1
SET ^ORD(100.6,ORI,0)="SPECIALTY CHANGE^S^"_ORDIV_U_ORSPEC_"^SPECIALTY CHANGE"
+2 DO MVTYPES(ORI,"20")
DO PKGS(ORI,.ORPARM)
+3 ;inactive
IF ORPARM<1
SET ^ORD(100.6,ORI,1)=ORNOW
+4 IF '$TEST
SET ^ORD(100.6,ORI,2,0)="^100.61DA^1^1"
SET ^(1,0)=ORNOW
P3 ; -- WARD TRANSFER rule
+1 SET ORI=ORI+1
SET ^ORD(100.6,ORI,0)="WARD TRANSFER^T^"_ORDIV_U_ORTRANS_"^WARD TRANSFER"
+2 DO MVTYPES(ORI,"4")
+3 SET ORPKG=1
SET ORPKG(1)=+$ORDER(^DIC(9.4,"C","OR",0))_"^1"
DO PKGS(ORI,.ORPKG)
+4 ;inactive
IF ORPARM("T")<1
SET ^ORD(100.6,ORI,1)=ORNOW
+5 IF '$TEST
SET ^ORD(100.6,ORI,2,0)="^100.61DA^1^1"
SET ^(1,0)=ORNOW
P4 ; -- DISCHARGE rule
+1 SET ORI=ORI+1
SET ^ORD(100.6,ORI,0)="DISCHARGE^D^"_ORDIV_U_ORDIS_"^DISCHARGE"
+2 DO MVTYPES(ORI,"10^11^16^17^21^27^31^32^33^34^35^37^42^46^47")
+3 FOR I="1^OR","2^FH"
SET ORPKG(+I)=+$ORDER(^DIC(9.4,"C",$PIECE(I,U,2),0))_"^1"
+4 SET ORPKG=2
DO PKGS(ORI,.ORPKG)
+5 ;active
SET ^ORD(100.6,ORI,2,0)="^100.61DA^1^1"
SET ^(1,0)=ORNOW
P5 ; -- DEATH rule
+1 SET ORI=ORI+1
SET ^ORD(100.6,ORI,0)="DEATH^D^"_ORDIV_U_ORDEATH_"^DEATH"
+2 SET ORPKG=4
FOR I="1^OR","2^FH","3^GMRC","4^RA"
SET ORPKG(+I)=+$ORDER(^DIC(9.4,"C",$PIECE(I,U,2),0))_"^1"
+3 DO PKGS(ORI,.ORPKG)
DO MVTYPES(ORI,"12^38")
+4 ;active
SET ^ORD(100.6,ORI,2,0)="^100.61DA^1^1"
SET ^(1,0)=ORNOW
+5 ; ** Create the following but leave inactive for now:
P6 ; -- OR rule
+1 SET ORI=ORI+1
SET ^ORD(100.6,ORI,0)="SURGERY^O^"_ORDIV_U_OROR_"^SURGERY"
+2 SET ORPKG=1
SET ORPKG(1)=+$ORDER(^DIC(9.4,"C","OR",0))_"^1"
DO PKGS(ORI,.ORPKG)
+3 SET ^ORD(100.6,ORI,1)=ORNOW
P7 ; -- ON PASS rule
+1 SET ORI=ORI+1
SET ^ORD(100.6,ORI,0)="ON PASS^T^"_ORDIV_U_ORPASS_"^ON PASS"
+2 DO MVTYPES(ORI,"1^2^3")
SET ^ORD(100.6,ORI,1)=ORNOW
P8 ; -- FROM PASS rule
+1 SET ORI=ORI+1
SET ^ORD(100.6,ORI,0)="FROM PASS^T^"_ORDIV_U_ORPASS_"^FROM PASS"
+2 DO MVTYPES(ORI,"22^23^24^25^26")
SET ^ORD(100.6,ORI,1)=ORNOW
P9 ; -- TO ASIH rule
+1 SET ORI=ORI+1
SET ^ORD(100.6,ORI,0)="TO ASIH^T^"_ORDIV_U_ORASIH_"^TO ASIH"
+2 DO MVTYPES(ORI,"13")
SET ^ORD(100.6,ORI,1)=ORNOW
P10 ; -- FROM ASIH rule
+1 SET ORI=ORI+1
SET ^ORD(100.6,ORI,0)="FROM ASIH^T^"_ORDIV_U_ORASIH_"^FROM ASIH"
+2 DO MVTYPES(ORI,"14")
SET ^ORD(100.6,ORI,1)=ORNOW
+3 SET $PIECE(^ORD(100.6,0),U,3,4)=ORI_U_ORI
+4 ;set xrefs
SET DIK="^ORD(100.6,"
DO IXALL^DIK
+5 ;Set edit history for new rules
+6 SET ORGLOB="^ORD(100.6,"
+7 SET ORI=0
FOR
SET ORI=$ORDER(^ORD(100.6,ORI))
if '+ORI
QUIT
DO AUDIT^OREV(ORI,"N")
+8 QUIT
+9 ;
MVTYPES(IEN,TYPES) ; -- save MAS Movement Types
+1 NEW CNT,I
SET CNT=$LENGTH(TYPES,U)
+2 SET ^ORD(100.6,IEN,3,0)="^100.63P^"_CNT_U_CNT
+3 FOR I=1:1:CNT
SET ^ORD(100.6,IEN,3,I,0)=+$PIECE(TYPES,U,I)
+4 QUIT
+5 ;
PKGS(IEN,PKGS) ; -- save Included Packages
+1 NEW CNT,I
SET CNT=+$GET(PKGS)
+2 SET ^ORD(100.6,IEN,7,0)="^100.67P^"_CNT_U_CNT
+3 FOR I=1:1:CNT
SET ^ORD(100.6,IEN,7,I,0)=+PKGS(I)
+4 QUIT
