ORY26 ;SLC/MKB-Postinit for patch OR*3*26
;;3.0;ORDER ENTRY/RESULTS REPORTING;**26**;Dec 17, 1997
;
ENV ; -- environment check
;
I '$L($T(GETSVC^GMRCPR0)) W !!,"GMRC*3*5 V5 or higher must be installed!" S XPDQUIT=1 Q
Q
;
PRE ; -- Kill B xref if first install, to be rebuilt in POST
;
D OI,PAIN ;inactivate invalid service orderables, add Pain
I '$O(^ORD(101.41,"B","OR GTX REQUEST SERVICE",0)) K ^ORD(101.43,"B")
Q
;
POST ; -- cleanup consult orderables, consult-type qo's
;
D XREF,GMRCT
Q
;
XREF ; -- Rebuild B, S.XXX xrefs on Orderable Items file #101.43
;
Q:$D(^ORD(101.43,"B")) N IDX,DIK,DA
S IDX="S" F S IDX=$O(^ORD(101.43,IDX)) Q:IDX'?1"S."1.U K ^(IDX)
S DIK="^ORD(101.43,",DIK(1)=".01^B^S0^SS2" D ENALL^DIK
;D EN^GMRCPOS1
Q
;
GMRCT ; -- new field for GMRCT* quick orders
;
N CT,FT,DG,ORDLG,OR0,DA,HDR
S FT=$$PTR^ORCD("OR GTX FREE TEXT 1"),CT=$$PTR^ORCD("OR GTX FREE TEXT OI"),DG=$O(^ORD(100.98,"B","CSLT",0)),ORDLG=0
F S ORDLG=$O(^ORD(101.41,ORDLG)) Q:ORDLG'>0 S OR0=$G(^(ORDLG,0)) D
. Q:$P(OR0,U,5)'=DG Q:$P(OR0,U,4)'="Q" ;must be consult qo
. S DA=+$O(^ORD(101.41,ORDLG,6,"D"),-1) ;last one
. Q:$P($G(^ORD(101.41,ORDLG,6,DA,0)),U,2)'=FT ;ok
. S HDR=^ORD(101.41,ORDLG,6,0) K ^(DA) S DA=DA-1
. S $P(^ORD(101.41,ORDLG,6,0),U,3,4)=DA_U_($P(HDR,U,4)-1)
S ORDLG=+$O(^ORD(101.41,"B","GMRCOR CONSULT",0))
S $P(^ORD(101.41,ORDLG,10,1,2),U,2)="@"_CT ;Format code
Q
;
OI ; -- validate Consult service orderables
;
N NM,IFN,OI,REBLD,NOW,USAGE,GMRC
S NM="",REBLD=0,NOW=$$NOW^XLFDT
F S NM=$O(^ORD(101.43,"S.CSLT",NM)) Q:NM="" S IFN=0 D
. F S IFN=$O(^ORD(101.43,"S.CSLT",NM,IFN)) Q:IFN'>0 D
. . S OI=$G(^ORD(101.43,IFN,0)),ID=$P(OI,U,2)
. . S GMRC=$G(^GMR(123.5,+ID,0)),USAGE=$P(GMRC,U,2)
. . I ID'?1.N1";99CON"!'$L(GMRC)!($P(GMRC,U)'=$P(OI,U)) D INACT Q
. . I USAGE=9 D:$G(^ORD(101.43,IFN,.1))'>0 INACT Q
. . S $P(^ORD(101.43,IFN,"CS"),U)=USAGE I $G(^(.1))>0 K ^(.1) S REBLD=1
K:$G(REBLD) ^ORD(101.43,"B") ;force postinit to rebuild
Q
;
INACT ; -- inactivate orderable, set REBLD flag
Q:$G(^ORD(101.43,IFN,.1))>0 ;already inactive
S ^ORD(101.43,IFN,.1)=NOW,REBLD=1
Q
;
PAIN ; -- add Pain to Orderable Items file
Q:$O(^ORD(101.43,"S.V/M","PAIN",0)) N X,Y,DIC,DA,DR,DIE,ID,ORDG
S X="Pain",DIC="^ORD(101.43,",DIC(0)="LX",DLAYGO=101.43
K DD,DO D FILE^DICN Q:Y'>0 S DA=+Y,DIE=DIC
S ORDG=+$O(^ORD(100.98,"B","V/M",0)),ID=DA_";99ORD"
S DR="1.1///"_X_";2///^S X=ID;5////"_ORDG D ^DIE
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORY26 2513 printed Nov 22, 2024@17:49:53 Page 2
ORY26 ;SLC/MKB-Postinit for patch OR*3*26
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**26**;Dec 17, 1997
+2 ;
ENV ; -- environment check
+1 ;
+2 IF '$LENGTH($TEXT(GETSVC^GMRCPR0))
WRITE !!,"GMRC*3*5 V5 or higher must be installed!"
SET XPDQUIT=1
QUIT
+3 QUIT
+4 ;
PRE ; -- Kill B xref if first install, to be rebuilt in POST
+1 ;
+2 ;inactivate invalid service orderables, add Pain
DO OI
DO PAIN
+3 IF '$ORDER(^ORD(101.41,"B","OR GTX REQUEST SERVICE",0))
KILL ^ORD(101.43,"B")
+4 QUIT
+5 ;
POST ; -- cleanup consult orderables, consult-type qo's
+1 ;
+2 DO XREF
DO GMRCT
+3 QUIT
+4 ;
XREF ; -- Rebuild B, S.XXX xrefs on Orderable Items file #101.43
+1 ;
+2 if $DATA(^ORD(101.43,"B"))
QUIT
NEW IDX,DIK,DA
+3 SET IDX="S"
FOR
SET IDX=$ORDER(^ORD(101.43,IDX))
if IDX'?1"S."1.U
QUIT
KILL ^(IDX)
+4 SET DIK="^ORD(101.43,"
SET DIK(1)=".01^B^S0^SS2"
DO ENALL^DIK
+5 ;D EN^GMRCPOS1
+6 QUIT
+7 ;
GMRCT ; -- new field for GMRCT* quick orders
+1 ;
+2 NEW CT,FT,DG,ORDLG,OR0,DA,HDR
+3 SET FT=$$PTR^ORCD("OR GTX FREE TEXT 1")
SET CT=$$PTR^ORCD("OR GTX FREE TEXT OI")
SET DG=$ORDER(^ORD(100.98,"B","CSLT",0))
SET ORDLG=0
+4 FOR
SET ORDLG=$ORDER(^ORD(101.41,ORDLG))
if ORDLG'>0
QUIT
SET OR0=$GET(^(ORDLG,0))
Begin DoDot:1
+5 ;must be consult qo
if $PIECE(OR0,U,5)'=DG
QUIT
if $PIECE(OR0,U,4)'="Q"
QUIT
+6 ;last one
SET DA=+$ORDER(^ORD(101.41,ORDLG,6,"D"),-1)
+7 ;ok
if $PIECE($GET(^ORD(101.41,ORDLG,6,DA,0)),U,2)'=FT
QUIT
+8 SET HDR=^ORD(101.41,ORDLG,6,0)
KILL ^(DA)
SET DA=DA-1
+9 SET $PIECE(^ORD(101.41,ORDLG,6,0),U,3,4)=DA_U_($PIECE(HDR,U,4)-1)
End DoDot:1
+10 SET ORDLG=+$ORDER(^ORD(101.41,"B","GMRCOR CONSULT",0))
+11 ;Format code
SET $PIECE(^ORD(101.41,ORDLG,10,1,2),U,2)="@"_CT
+12 QUIT
+13 ;
OI ; -- validate Consult service orderables
+1 ;
+2 NEW NM,IFN,OI,REBLD,NOW,USAGE,GMRC
+3 SET NM=""
SET REBLD=0
SET NOW=$$NOW^XLFDT
+4 FOR
SET NM=$ORDER(^ORD(101.43,"S.CSLT",NM))
if NM=""
QUIT
SET IFN=0
Begin DoDot:1
+5 FOR
SET IFN=$ORDER(^ORD(101.43,"S.CSLT",NM,IFN))
if IFN'>0
QUIT
Begin DoDot:2
+6 SET OI=$GET(^ORD(101.43,IFN,0))
SET ID=$PIECE(OI,U,2)
+7 SET GMRC=$GET(^GMR(123.5,+ID,0))
SET USAGE=$PIECE(GMRC,U,2)
+8 IF ID'?1.N1";99CON"!'$LENGTH(GMRC)!($PIECE(GMRC,U)'=$PIECE(OI,U))
DO INACT
QUIT
+9 IF USAGE=9
if $GET(^ORD(101.43,IFN,.1))'>0
DO INACT
QUIT
+10 SET $PIECE(^ORD(101.43,IFN,"CS"),U)=USAGE
IF $GET(^(.1))>0
KILL ^(.1)
SET REBLD=1
End DoDot:2
End DoDot:1
+11 ;force postinit to rebuild
if $GET(REBLD)
KILL ^ORD(101.43,"B")
+12 QUIT
+13 ;
INACT ; -- inactivate orderable, set REBLD flag
+1 ;already inactive
if $GET(^ORD(101.43,IFN,.1))>0
QUIT
+2 SET ^ORD(101.43,IFN,.1)=NOW
SET REBLD=1
+3 QUIT
+4 ;
PAIN ; -- add Pain to Orderable Items file
+1 if $ORDER(^ORD(101.43,"S.V/M","PAIN",0))
QUIT
NEW X,Y,DIC,DA,DR,DIE,ID,ORDG
+2 SET X="Pain"
SET DIC="^ORD(101.43,"
SET DIC(0)="LX"
SET DLAYGO=101.43
+3 KILL DD,DO
DO FILE^DICN
if Y'>0
QUIT
SET DA=+Y
SET DIE=DIC
+4 SET ORDG=+$ORDER(^ORD(100.98,"B","V/M",0))
SET ID=DA_";99ORD"
+5 SET DR="1.1///"_X_";2///^S X=ID;5////"_ORDG
DO ^DIE
+6 QUIT
