ORY141ED ; SLC/MKB - EDO inits for patch OR*3*141 ;8/19/02 10:45
;;3.0;ORDER ENTRY/RESULTS REPORTING;**141**;Dec 17, 1997
;
PRE ; -- preinit: remove old DD's
Q:$O(^ORD(101,"B","ORC DELAYED ORDERS",0)) ;not 1st install
N DIU,ORNOW,XMDUZ,XMDUN,XMY,X,XMOUT
S DIU="^OR(100.2,",DIU(0)="DST" D EN^DIU2 ;remove old DD
D DELIX^DDMOD(100,.02,4),DELIX^DDMOD(100,15,1) ;remove old AEVNT xrefs
S ORNOW=$$NOW^XLFDT K ^XTMP("ORYED")
S ^XTMP("ORYED",0)=$$FMADD^XLFDT(ORNOW,90)_U_ORNOW_"^OR*3*141 Delay Event Conversion"
W !!,"A mail message will be generated when the post-init conversion has completed."
S XMDUZ=DUZ,XMDUN=$P($G(^VA(200,DUZ,0)),U) D DEST^XMA21
I $D(XMOUT) W !!,$C(7),"Only the installer of this patch will receive the conversion bulletin!" S XMY(DUZ)=""
M ^XTMP("ORYED","XMY")=XMY
Q
;
DLGSEND(X) ; -- Send order dialog X?
I X="LR OTHER LAB TESTS" Q 1
I X="RA OERR EXAM" Q 1
I X="PS MEDS" Q 1
I X="PSJ OR PAT OE" Q 1
I X="PSO OERR" Q 1
I X="PSO SUPPLY" Q 1
I X="OR GXMOVE ADMIT PATIENT" Q 1
I X="OR GXMOVE DISCHARGE" Q 1
I X="OR GXMOVE TRANSFER" Q 1
I X="OR GXMOVE TREATING SPECIALTY" Q 1
Q 0
;
POST ; -- postinit: convert orders, remove old parameters
S ^ORD(100.01,10,.1)="dly"
S ^ORD(100.01,13,1,1,0)="Orders that have been rejected by the ancillary service without being"
S ^ORD(100.01,13,1,2,0)="acted on, or terminated while still delayed."
K ^DIC(100.5,0,"RD"),^DIC(100.6,0,"RD") ;remove read access
D 101,AEVNT,PARAMS,DLGS,C
Q
;
AEVNT ; -- postinit: convert Event field #15 of Orders file #100
; from code (A/D/T) to pointer to #100.2
; (incl a report of bad data, lapsed orders)
;
Q:'$D(^XTMP("ORYED","XMY")) ;not 1st install
N ORPARAM,ORLAPSE,ORSITE,ORVP,ORDIED,OREVT,ORIFN,OR0,OR3,ORTS,ORL,ORDIV,ORX,ORNOW,ORPTEVT
S ORPARAM=+$$GET^XPAR("ALL","OR DELAYED ORDERS LAPSE DAYS"),ORLAPSE=0
S:ORPARAM ORLAPSE=$$FMADD^XLFDT(DT,(0-ORPARAM)) ;=0 or cutoff date
S ORNOW=$$NOW^XLFDT,ORSITE=+$$SITE^VASITE ;[primary] division
S ORVP="" F S ORVP=$O(^OR(100,"AEVNT",ORVP)) Q:ORVP="" D
. S ORL="",ORDIED=+$G(^DPT(+ORVP,.35)) I $L($G(^(.1))) S ORL=+$O(^DIC(42,"B",^(.1),0)),ORL=$G(^DIC(42,ORL,44))
. F OREVT="A","T","D" S ORIFN=0 D
.. F S ORIFN=+$O(^OR(100,"AEVNT",ORVP,OREVT,ORIFN)) Q:ORIFN<1 D
... S OR0=$G(^OR(100,ORIFN,0)),OR3=$G(^(3)) I '$L($P(OR0,U,17)) D CLEAR Q
... S ORX=$P(OR0,U,10) S:'ORX ORX=ORL
... S ORDIV=$$DIV^OREVNTX(ORX) S:ORDIV<1 ORDIV=ORSITE
... I $P(OR3,U,3)'=10 D CLEAR,ERR(1) Q ;discharge meds
... S ORTS=+$P(OR0,U,13) I OREVT'="D",ORTS<1 D STATUS^ORCSAVE2(ORIFN,13),CLEAR,ERR(2) Q ;error
... I $P(OR0,U,7)<ORLAPSE D STATUS^ORCSAVE2(ORIFN,14),CLEAR,ERR(3) Q
... I ORDIED D CANCEL,CLEAR,ERR(4) Q
... S ORX=OREVT_U_$S(OREVT'="D":ORTS,1:"")_U_ORDIV
... S ^XTMP("ORYED","EVT",ORX)="",^(ORX,ORVP)="",^(ORVP,ORIFN)=""
Q:'$L($O(^XTMP("ORYED","EVT",""))) ;no delayed orders to convert
AE1 S ORX="" F S ORX=$O(^XTMP("ORYED","EVT",ORX)) Q:ORX="" D
. S OREVT=$$EVENT(ORX) Q:OREVT<1 S ^XTMP("ORYED","EVT",ORX)=OREVT
. S ORVP="" F S ORVP=$O(^XTMP("ORYED","EVT",ORX,ORVP)) Q:ORVP="" D
.. S ORPTEVT=$$NEW^OREVNT(+ORVP,+OREVT) Q:ORPTEVT<1
.. S ^XTMP("ORYED","EVT",ORX,ORVP)=ORPTEVT D SET(ORVP,ORX,OREVT)
.. S ORIFN=0 F S ORIFN=+$O(^XTMP("ORYED","EVT",ORX,ORVP,ORIFN)) Q:ORIFN<1 D
... S $P(^OR(100,ORIFN,0),U,17)=ORPTEVT
... K ^OR(100,"AEVNT",ORVP,$P(ORX,U),ORIFN)
... S ^OR(100,"AEVNT",ORVP,ORPTEVT,ORIFN)=""
D BULLETIN K ^XTMP("ORYED","XMY")
Q
;
CANCEL ; -- Cancel order for deceased patient
S ^OR(100,ORIFN,6)=$O(^ORD(100.02,"C","A",0))_U_U_ORNOW_U_+$O(^ORD(100.03,"C","ORDEATH",0))
D STATUS^ORCSAVE2(ORIFN,13) S $P(^OR(100,ORIFN,8,1,0),U,15)=13
Q
;
CLEAR ; -- Clear Event code field
S $P(^OR(100,ORIFN,0),U,17)="" S:$P($G(^(8,1,0)),U,15)=10 $P(^(0),U,15)=""
K ^OR(100,"AEVNT",ORVP,OREVT,ORIFN)
Q
;
EVENT(X) ; -- Find (or create) event in #100.5 for
; X = A/D/T ^ [TS] ^ DIV ptr
N I,Y,TS,DIV,ORY,X0,MVT,ORGLOB
S TS=+$P(X,U,2),DIV=+$P(X,U,3),X=$P(X,U),Y=0 K ORY
S I=0 F S I=+$O(^ORD(100.5,"ADT",X,I)) Q:I<1 D ;find matches
. S X0=$G(^ORD(100.5,I,0)) Q:DIV'=$P(X0,U,3)
. I TS Q:'$O(^ORD(100.5,I,"TS","B",TS,0))
. S MVT=+$P(X0,U,7) I MVT Q:$S(X="A":MVT'=15,X="T":MVT'=4,1:MVT'=16)
. S ORY(+$G(^ORD(100.5,I,1)),MVT,I)="" ;=ORY(InactDt,MvtType,IEN)
S I="ORY",I=$Q(@I),Y=+$P(I,",",3)
I Y<1 D ;create new inactive event
. N I,HDR,LAST,TOTAL,DA,NAME
. F I=1:1:10 L +^ORD(100.5,0):1 Q:$T H 2
. I '$T S Y="" Q
. S HDR=$G(^ORD(100.5,0)),TOTAL=$P(HDR,U,4),LAST=$O(^ORD(100.5,"?"),-1)
. S I=LAST F I=(I+1):1 Q:'$D(^ORD(100.5,I,0))
. S Y=I,$P(HDR,U,3,4)=Y_U_(TOTAL+1)
. S ^ORD(100.5,0)=HDR L -^ORD(100.5,0)
. S NAME=$S(X="A":"ADMIT",X="T":"TRANSFER",X="D":"DISCHARGE",1:"")_$S(TS:" TO "_$P($G(^DIC(45.7,+TS,0)),U),1:"")_" ("_DIV_")"
. S ^ORD(100.5,Y,0)=NAME_U_X_U_DIV_"^^^"_ORPARAM_"^^"_NAME,^(1)=ORNOW
. S ^ORD(100.5,"B",$E(NAME,1,30),Y)="",^ORD(100.5,"ADT",X,Y)=""
. I TS S ^ORD(100.5,Y,"TS",0)="^100.51P^1^1",^(1,0)=TS,^ORD(100.5,Y,"TS","B",TS,1)=""
. S ORGLOB="^ORD(100.5," D AUDIT^OREV(Y,"N") ;Set edit history for new rule
Q Y
;
ERR(X) ; -- Track orders unable to convert
N MSG,STS S X=+$G(X),STS=$P(OR3,U,3)
S MSG=$S(X=2:"<Missing or invalid specialty>",X=3!(STS=14):"<Lapsed>",STS=12:"<Changed>",STS=1!(STS=13):"<Cancelled>",1:"<Already released>")
S ^XTMP("ORYED","ERR",ORVP,ORIFN)=OREVT_U_$G(ORTS)_U_MSG
; Include missing TS, newly lapsed orders in bulletin:
;D:X>1 SET(ORVP,OREVT_U_$G(ORTS)_U_ORDIV,MSG)
Q
;
SET(PAT,OLD,NEW) ; -- set xref nodes in XTMP for bulletin
N PNM,EVT,DIV,DIVNM,TS,NEWNM
S PNM=$P($G(^DPT(+PAT,0)),U)_" ("_$P($G(^(.36)),U,4)_")"
S EVT=$P(OLD,U) S:EVT="D" TS="none" I "AT"[EVT D
. S TS=$P(OLD,U,2),X0=$S(TS:$G(^DIC(45.7,+TS,0)),1:"unk")
. S TS=$S($L($P(X0,U,5)):$P(X0,U,5),1:$E($P(X0,U),1,5))
S DIV=+$P(OLD,U,3),DIVNM=$S(DIV:$P($G(^DIC(4,DIV,0)),U),1:"UNKNOWN")
S NEWNM=$S(NEW:$P($G(^ORD(100.5,+NEW,0)),U),1:NEW) ;EvtNm or ErrMsg
S ^XTMP("ORYED","B",DIVNM,EVT,TS)=NEWNM,^(TS,PNM)=OLD_"~"_PAT
Q
;
BULLETIN ; -- send bulletin when finished
N DIFROM,XMSUB,XMTEXT,XMDUZ,XMY,XMZ,XMMG,I,J,ORZ,DIV,EVT,TS,NEWEVT,X,PAT,ORX,ORVP,ORIFN,ORDERS,MAX
S XMDUZ="PATCH OR*3*141 CONVERSION",XMY(.5)="" S:$G(DUZ) XMY(DUZ)=""
I $D(^XTMP("ORYED","XMY")) M XMY=^XTMP("ORYED","XMY") ;recipients
S ^TMP("ORTXT",$J,1)="The Delayed Order conversion of patch OR*3*141 has completed."
B1 S I=1 I $D(^XTMP("ORYED","B")) D
. S I=I+1,^TMP("ORTXT",$J,I)=" "
. S I=I+1,^TMP("ORTXT",$J,I)="The following patients had delayed orders at the time of installation."
. S I=I+1,^TMP("ORTXT",$J,I)="For each, any event codes and treating specialties formerly in use are"
. S I=I+1,^TMP("ORTXT",$J,I)="listed on the left, with the new entry it was mapped to in the OE/RR"
. S I=I+1,^TMP("ORTXT",$J,I)="RELEASE EVENTS file #100.5, if possible, on the right:"
. S DIV="" F S DIV=$O(^XTMP("ORYED","B",DIV)) Q:DIV="" D
.. S I=I+1,^TMP("ORTXT",$J,I)=" "
.. S I=I+1,^TMP("ORTXT",$J,I)=DIV_":",ORZ=$$REPEAT^XLFSTR("-",$L(DIV))
.. F EVT="A","T","D" S TS="" F S TS=$O(^XTMP("ORYED","B",DIV,EVT,TS)) Q:TS="" S NEWEVT=$G(^(TS)) D
... S I=I+1,^TMP("ORTXT",$J,I)=ORZ,ORZ=" "
... S X=$S(EVT="D":"DISCHARGE",1:EVT_"/"_TS)
... S I=I+1,^TMP("ORTXT",$J,I)=$$LJ^XLFSTR(X,9)_" => "_NEWEVT
... S PAT="" F S PAT=$O(^XTMP("ORYED","B",DIV,EVT,TS,PAT)) Q:PAT="" S ORX=$G(^(PAT)) D
.... S ORVP=$P(ORX,"~",2),ORX=$P(ORX,"~"),MAX=68-$L(PAT)
.... S (ORIFN,ORDERS)=0,X="#"
.... F S ORIFN=+$O(^XTMP("ORYED","EVT",ORX,ORVP,ORIFN)) Q:ORIFN<1 D
..... I $L(X)+$L(ORIFN)+1'>MAX S X=X_$S($L(X)>1:",",1:"")_ORIFN Q
..... S ORDERS=ORDERS+1,ORDERS(ORDERS)=X_",",X=ORIFN
.... S ORDERS=ORDERS+1,ORDERS(ORDERS)=X,X=" "_PAT_": "
.... F J=1:1:ORDERS S I=I+1,^TMP("ORTXT",$J,I)=X_ORDERS(J),X=" "
S XMSUB="PATCH OR*3*141 CONVERSION COMPLETED"
S XMTEXT="^TMP(""ORTXT"","_$J_"," D ^XMD
K ^TMP("ORTXT",$J)
Q
;
PARAMS ; -- Remove old parameters, template
;
N DA,DIK,ORI
S DIK="^XTV(8989.52,",DA=+$O(^XTV(8989.52,"B","ORP AUTODC ORDERS",0)) D:DA ^DIK
F ORI="OR DC GEN ORD ON ADMISSION","ORPF DC OF GENERIC ORDERS","OR DC ON SPEC CHANGE","OR DELAYED ORDERS LAPSE DAYS" D
. S DIK="^XTV(8989.51,",DA=+$O(^XTV(8989.51,"B",ORI,0))
. D:DA ^DIK
Q
;
DLGS ; -- Send bulletin re modified dialogs
N I,ORD
F I="LR OTHER LAB TESTS","RA OERR EXAM","PS MEDS","PSJ OR PAT OE","PSO OERR","PSO SUPPLY","OR GXMOVE ADMIT PATIENT","OR GXMOVE DISCHARGE","OR GXMOVE TRANSFER","OR GXMOVE TREATING SPECIALTY" S ORD(I)=""
D EN^ORYDLG(141,.ORD)
Q
;
101 ; -- replace items on protocol menus
N ORI,ORX,ORMENU,OROLD,ORNEW,ORMNEM,DA,DR,DIE,X,Y
F ORI=1:1 S ORX=$T(PRTCLS+ORI) Q:ORX["ZZZZZ" D
. S ORMENU=+$O(^ORD(101,"B",$P(ORX,";",3),0)) Q:ORMENU<1
. S OROLD=+$O(^ORD(101,"B",$P(ORX,";",4),0)) Q:OROLD<1
. S DA=+$O(^ORD(101,ORMENU,10,"B",OROLD,0)) Q:DA<1 ;already fixed
. S ORNEW=$P(ORX,";",5),ORMNEM=$P(ORX,";",6)
. S DIE="^ORD(101,"_ORMENU_",10,",DA(1)=ORMENU
. S DR=".01///^S X=ORNEW;2///^S X=ORMNEM;5///@;6///@" D ^DIE
Q
;
PRTCLS ;;MENU;REPL;WITH;MNEMONIC
;;ORCHART ORDERS MENU;ORB BLANK LINE1;ORC DELAYED ORDERS;TD
;;ORC ADD ORDERS MENU;ORC EVENT MENU;VALM PREVIOUS SCREEN;-
;;ZZZZZ
;
C ; -- Rebuild C index on #100.5 to uppercase
N X,X1,DA K ^TMP($J,"ORD100.5C")
S X="" F S X=$O(^ORD(100.5,"C",X)) Q:X="" D
. S X1=$$UP^XLFSTR(X),DA=0
. F S DA=$O(^ORD(100.5,"C",X,DA)) Q:DA<1 S ^TMP($J,"ORD100.5C",X1,DA)=""
K ^ORD(100.5,"C") M ^ORD(100.5,"C")=^TMP($J,"ORD100.5C")
K ^TMP($J,"ORD100.5C")
Q
ORY141ED ; SLC/MKB - EDO inits for patch OR*3*141 ;8/19/02 10:45
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**141**;Dec 17, 1997
+2 ;
PRE ; -- preinit: remove old DD's
+1 ;not 1st install
IF $ORDER(^ORD(101,"B","ORC DELAYED ORDERS",0))
QUIT
+2 NEW DIU,ORNOW,XMDUZ,XMDUN,XMY,X,XMOUT
+3 ;remove old DD
SET DIU="^OR(100.2,"
SET DIU(0)="DST"
DO EN^DIU2
+4 ;remove old AEVNT xrefs
DO DELIX^DDMOD(100,.02,4)
DO DELIX^DDMOD(100,15,1)
+5 SET ORNOW=$$NOW^XLFDT
KILL ^XTMP("ORYED")
+6 SET ^XTMP("ORYED",0)=$$FMADD^XLFDT(ORNOW,90)_U_ORNOW_"^OR*3*141 Delay Event Conversion"
+7 WRITE !!,"A mail message will be generated when the post-init conversion has completed."
+8 SET XMDUZ=DUZ
SET XMDUN=$PIECE($GET(^VA(200,DUZ,0)),U)
DO DEST^XMA21
+9 IF $DATA(XMOUT)
WRITE !!,$CHAR(7),"Only the installer of this patch will receive the conversion bulletin!"
SET XMY(DUZ)=""
+10 MERGE ^XTMP("ORYED","XMY")=XMY
+11 QUIT
+12 ;
DLGSEND(X) ; -- Send order dialog X?
+1 IF X="LR OTHER LAB TESTS"
QUIT 1
+2 IF X="RA OERR EXAM"
QUIT 1
+3 IF X="PS MEDS"
QUIT 1
+4 IF X="PSJ OR PAT OE"
QUIT 1
+5 IF X="PSO OERR"
QUIT 1
+6 IF X="PSO SUPPLY"
QUIT 1
+7 IF X="OR GXMOVE ADMIT PATIENT"
QUIT 1
+8 IF X="OR GXMOVE DISCHARGE"
QUIT 1
+9 IF X="OR GXMOVE TRANSFER"
QUIT 1
+10 IF X="OR GXMOVE TREATING SPECIALTY"
QUIT 1
+11 QUIT 0
+12 ;
POST ; -- postinit: convert orders, remove old parameters
+1 SET ^ORD(100.01,10,.1)="dly"
+2 SET ^ORD(100.01,13,1,1,0)="Orders that have been rejected by the ancillary service without being"
+3 SET ^ORD(100.01,13,1,2,0)="acted on, or terminated while still delayed."
+4 ;remove read access
KILL ^DIC(100.5,0,"RD"),^DIC(100.6,0,"RD")
+5 DO 101
DO AEVNT
DO PARAMS
DO DLGS
DO C
+6 QUIT
+7 ;
AEVNT ; -- postinit: convert Event field #15 of Orders file #100
+1 ; from code (A/D/T) to pointer to #100.2
+2 ; (incl a report of bad data, lapsed orders)
+3 ;
+4 ;not 1st install
IF '$DATA(^XTMP("ORYED","XMY"))
QUIT
+5 NEW ORPARAM,ORLAPSE,ORSITE,ORVP,ORDIED,OREVT,ORIFN,OR0,OR3,ORTS,ORL,ORDIV,ORX,ORNOW,ORPTEVT
+6 SET ORPARAM=+$$GET^XPAR("ALL","OR DELAYED ORDERS LAPSE DAYS")
SET ORLAPSE=0
+7 ;=0 or cutoff date
IF ORPARAM
SET ORLAPSE=$$FMADD^XLFDT(DT,(0-ORPARAM))
+8 ;[primary] division
SET ORNOW=$$NOW^XLFDT
SET ORSITE=+$$SITE^VASITE
+9 SET ORVP=""
FOR
SET ORVP=$ORDER(^OR(100,"AEVNT",ORVP))
IF ORVP=""
QUIT
Begin DoDot:1
+10 SET ORL=""
SET ORDIED=+$GET(^DPT(+ORVP,.35))
IF $LENGTH($GET(^(.1)))
SET ORL=+$ORDER(^DIC(42,"B",^(.1),0))
SET ORL=$GET(^DIC(42,ORL,44))
+11 FOR OREVT="A","T","D"
SET ORIFN=0
Begin DoDot:2
+12 FOR
SET ORIFN=+$ORDER(^OR(100,"AEVNT",ORVP,OREVT,ORIFN))
IF ORIFN<1
QUIT
Begin DoDot:3
+13 SET OR0=$GET(^OR(100,ORIFN,0))
SET OR3=$GET(^(3))
IF '$LENGTH($PIECE(OR0,U,17))
DO CLEAR
QUIT
+14 SET ORX=$PIECE(OR0,U,10)
IF 'ORX
SET ORX=ORL
+15 SET ORDIV=$$DIV^OREVNTX(ORX)
IF ORDIV<1
SET ORDIV=ORSITE
+16 ;discharge meds
IF $PIECE(OR3,U,3)'=10
DO CLEAR
DO ERR(1)
QUIT
+17 ;error
SET ORTS=+$PIECE(OR0,U,13)
IF OREVT'="D"
IF ORTS<1
DO STATUS^ORCSAVE2(ORIFN,13)
DO CLEAR
DO ERR(2)
QUIT
+18 IF $PIECE(OR0,U,7)<ORLAPSE
DO STATUS^ORCSAVE2(ORIFN,14)
DO CLEAR
DO ERR(3)
QUIT
+19 IF ORDIED
DO CANCEL
DO CLEAR
DO ERR(4)
QUIT
+20 SET ORX=OREVT_U_$SELECT(OREVT'="D":ORTS,1:"")_U_ORDIV
+21 SET ^XTMP("ORYED","EVT",ORX)=""
SET ^(ORX,ORVP)=""
SET ^(ORVP,ORIFN)=""
End DoDot:3
End DoDot:2
End DoDot:1
+22 ;no delayed orders to convert
IF '$LENGTH($ORDER(^XTMP("ORYED","EVT","")))
QUIT
AE1 SET ORX=""
FOR
SET ORX=$ORDER(^XTMP("ORYED","EVT",ORX))
IF ORX=""
QUIT
Begin DoDot:1
+1 SET OREVT=$$EVENT(ORX)
IF OREVT<1
QUIT
SET ^XTMP("ORYED","EVT",ORX)=OREVT
+2 SET ORVP=""
FOR
SET ORVP=$ORDER(^XTMP("ORYED","EVT",ORX,ORVP))
IF ORVP=""
QUIT
Begin DoDot:2
+3 SET ORPTEVT=$$NEW^OREVNT(+ORVP,+OREVT)
IF ORPTEVT<1
QUIT
+4 SET ^XTMP("ORYED","EVT",ORX,ORVP)=ORPTEVT
DO SET(ORVP,ORX,OREVT)
+5 SET ORIFN=0
FOR
SET ORIFN=+$ORDER(^XTMP("ORYED","EVT",ORX,ORVP,ORIFN))
IF ORIFN<1
QUIT
Begin DoDot:3
+6 SET $PIECE(^OR(100,ORIFN,0),U,17)=ORPTEVT
+7 KILL ^OR(100,"AEVNT",ORVP,$PIECE(ORX,U),ORIFN)
+8 SET ^OR(100,"AEVNT",ORVP,ORPTEVT,ORIFN)=""
End DoDot:3
End DoDot:2
End DoDot:1
+9 DO BULLETIN
KILL ^XTMP("ORYED","XMY")
+10 QUIT
+11 ;
CANCEL ; -- Cancel order for deceased patient
+1 SET ^OR(100,ORIFN,6)=$ORDER(^ORD(100.02,"C","A",0))_U_U_ORNOW_U_+$ORDER(^ORD(100.03,"C","ORDEATH",0))
+2 DO STATUS^ORCSAVE2(ORIFN,13)
SET $PIECE(^OR(100,ORIFN,8,1,0),U,15)=13
+3 QUIT
+4 ;
CLEAR ; -- Clear Event code field
+1 SET $PIECE(^OR(100,ORIFN,0),U,17)=""
IF $PIECE($GET(^(8,1,0)),U,15)=10
SET $PIECE(^(0),U,15)=""
+2 KILL ^OR(100,"AEVNT",ORVP,OREVT,ORIFN)
+3 QUIT
+4 ;
EVENT(X) ; -- Find (or create) event in #100.5 for
+1 ; X = A/D/T ^ [TS] ^ DIV ptr
+2 NEW I,Y,TS,DIV,ORY,X0,MVT,ORGLOB
+3 SET TS=+$PIECE(X,U,2)
SET DIV=+$PIECE(X,U,3)
SET X=$PIECE(X,U)
SET Y=0
KILL ORY
+4 ;find matches
SET I=0
FOR
SET I=+$ORDER(^ORD(100.5,"ADT",X,I))
IF I<1
QUIT
Begin DoDot:1
+5 SET X0=$GET(^ORD(100.5,I,0))
IF DIV'=$PIECE(X0,U,3)
QUIT
+6 IF TS
IF '$ORDER(^ORD(100.5,I,"TS","B",TS,0))
QUIT
+7 SET MVT=+$PIECE(X0,U,7)
IF MVT
IF $SELECT(X="A"
QUIT
+8 ;=ORY(InactDt,MvtType,IEN)
SET ORY(+$GET(^ORD(100.5,I,1)),MVT,I)=""
End DoDot:1
+9 SET I="ORY"
SET I=$QUERY(@I)
SET Y=+$PIECE(I,",",3)
+10 ;create new inactive event
IF Y<1
Begin DoDot:1
+11 NEW I,HDR,LAST,TOTAL,DA,NAME
+12 FOR I=1:1:10
LOCK +^ORD(100.5,0):1
IF $TEST
QUIT
HANG 2
+13 IF '$TEST
SET Y=""
QUIT
+14 SET HDR=$GET(^ORD(100.5,0))
SET TOTAL=$PIECE(HDR,U,4)
SET LAST=$ORDER(^ORD(100.5,"?"),-1)
+15 SET I=LAST
FOR I=(I+1):1
IF '$DATA(^ORD(100.5,I,0))
QUIT
+16 SET Y=I
SET $PIECE(HDR,U,3,4)=Y_U_(TOTAL+1)
+17 SET ^ORD(100.5,0)=HDR
LOCK -^ORD(100.5,0)
+18 SET NAME=$SELECT(X="A":"ADMIT",X="T":"TRANSFER",X="D":"DISCHARGE",1:"")_$SELECT(TS:" TO "_$PIECE($GET(^DIC(45.7,+TS,0)),U),1:"")_" ("_DIV_")"
+19 SET ^ORD(100.5,Y,0)=NAME_U_X_U_DIV_"^^^"_ORPARAM_"^^"_NAME
SET ^(1)=ORNOW
+20 SET ^ORD(100.5,"B",$EXTRACT(NAME,1,30),Y)=""
SET ^ORD(100.5,"ADT",X,Y)=""
+21 IF TS
SET ^ORD(100.5,Y,"TS",0)="^100.51P^1^1"
SET ^(1,0)=TS
SET ^ORD(100.5,Y,"TS","B",TS,1)=""
+22 ;Set edit history for new rule
SET ORGLOB="^ORD(100.5,"
DO AUDIT^OREV(Y,"N")
End DoDot:1
+23 QUIT Y
+24 ;
ERR(X) ; -- Track orders unable to convert
+1 NEW MSG,STS
SET X=+$GET(X)
SET STS=$PIECE(OR3,U,3)
+2 SET MSG=$SELECT(X=2:"<Missing or invalid specialty>",X=3!(STS=14):"<Lapsed>",STS=12:"<Changed>",STS=1!(STS=13):"<Cancelled>",1:"<Already released>")
+3 SET ^XTMP("ORYED","ERR",ORVP,ORIFN)=OREVT_U_$GET(ORTS)_U_MSG
+4 ; Include missing TS, newly lapsed orders in bulletin:
+5 ;D:X>1 SET(ORVP,OREVT_U_$G(ORTS)_U_ORDIV,MSG)
+6 QUIT
+7 ;
SET(PAT,OLD,NEW) ; -- set xref nodes in XTMP for bulletin
+1 NEW PNM,EVT,DIV,DIVNM,TS,NEWNM
+2 SET PNM=$PIECE($GET(^DPT(+PAT,0)),U)_" ("_$PIECE($GET(^(.36)),U,4)_")"
+3 SET EVT=$PIECE(OLD,U)
IF EVT="D"
SET TS="none"
IF "AT"[EVT
Begin DoDot:1
+4 SET TS=$PIECE(OLD,U,2)
SET X0=$SELECT(TS:$GET(^DIC(45.7,+TS,0)),1:"unk")
+5 SET TS=$SELECT($LENGTH($PIECE(X0,U,5)):$PIECE(X0,U,5),1:$EXTRACT($PIECE(X0,U),1,5))
End DoDot:1
+6 SET DIV=+$PIECE(OLD,U,3)
SET DIVNM=$SELECT(DIV:$PIECE($GET(^DIC(4,DIV,0)),U),1:"UNKNOWN")
+7 ;EvtNm or ErrMsg
SET NEWNM=$SELECT(NEW:$PIECE($GET(^ORD(100.5,+NEW,0)),U),1:NEW)
+8 SET ^XTMP("ORYED","B",DIVNM,EVT,TS)=NEWNM
SET ^(TS,PNM)=OLD_"~"_PAT
+9 QUIT
+10 ;
BULLETIN ; -- send bulletin when finished
+1 NEW DIFROM,XMSUB,XMTEXT,XMDUZ,XMY,XMZ,XMMG,I,J,ORZ,DIV,EVT,TS,NEWEVT,X,PAT,ORX,ORVP,ORIFN,ORDERS,MAX
+2 SET XMDUZ="PATCH OR*3*141 CONVERSION"
SET XMY(.5)=""
IF $GET(DUZ)
SET XMY(DUZ)=""
+3 ;recipients
IF $DATA(^XTMP("ORYED","XMY"))
MERGE XMY=^XTMP("ORYED","XMY")
+4 SET ^TMP("ORTXT",$JOB,1)="The Delayed Order conversion of patch OR*3*141 has completed."
B1 SET I=1
IF $DATA(^XTMP("ORYED","B"))
Begin DoDot:1
+1 SET I=I+1
SET ^TMP("ORTXT",$JOB,I)=" "
+2 SET I=I+1
SET ^TMP("ORTXT",$JOB,I)="The following patients had delayed orders at the time of installation."
+3 SET I=I+1
SET ^TMP("ORTXT",$JOB,I)="For each, any event codes and treating specialties formerly in use are"
+4 SET I=I+1
SET ^TMP("ORTXT",$JOB,I)="listed on the left, with the new entry it was mapped to in the OE/RR"
+5 SET I=I+1
SET ^TMP("ORTXT",$JOB,I)="RELEASE EVENTS file #100.5, if possible, on the right:"
+6 SET DIV=""
FOR
SET DIV=$ORDER(^XTMP("ORYED","B",DIV))
IF DIV=""
QUIT
Begin DoDot:2
+7 SET I=I+1
SET ^TMP("ORTXT",$JOB,I)=" "
+8 SET I=I+1
SET ^TMP("ORTXT",$JOB,I)=DIV_":"
SET ORZ=$$REPEAT^XLFSTR("-",$LENGTH(DIV))
+9 FOR EVT="A","T","D"
SET TS=""
FOR
SET TS=$ORDER(^XTMP("ORYED","B",DIV,EVT,TS))
IF TS=""
QUIT
SET NEWEVT=$GET(^(TS))
Begin DoDot:3
+10 SET I=I+1
SET ^TMP("ORTXT",$JOB,I)=ORZ
SET ORZ=" "
+11 SET X=$SELECT(EVT="D":"DISCHARGE",1:EVT_"/"_TS)
+12 SET I=I+1
SET ^TMP("ORTXT",$JOB,I)=$$LJ^XLFSTR(X,9)_" => "_NEWEVT
+13 SET PAT=""
FOR
SET PAT=$ORDER(^XTMP("ORYED","B",DIV,EVT,TS,PAT))
IF PAT=""
QUIT
SET ORX=$GET(^(PAT))
Begin DoDot:4
+14 SET ORVP=$PIECE(ORX,"~",2)
SET ORX=$PIECE(ORX,"~")
SET MAX=68-$LENGTH(PAT)
+15 SET (ORIFN,ORDERS)=0
SET X="#"
+16 FOR
SET ORIFN=+$ORDER(^XTMP("ORYED","EVT",ORX,ORVP,ORIFN))
IF ORIFN<1
QUIT
Begin DoDot:5
+17 IF $LENGTH(X)+$LENGTH(ORIFN)+1'>MAX
SET X=X_$SELECT($LENGTH(X)>1:",",1:"")_ORIFN
QUIT
+18 SET ORDERS=ORDERS+1
SET ORDERS(ORDERS)=X_","
SET X=ORIFN
End DoDot:5
+19 SET ORDERS=ORDERS+1
SET ORDERS(ORDERS)=X
SET X=" "_PAT_": "
+20 FOR J=1:1:ORDERS
SET I=I+1
SET ^TMP("ORTXT",$JOB,I)=X_ORDERS(J)
SET X=" "
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+21 SET XMSUB="PATCH OR*3*141 CONVERSION COMPLETED"
+22 SET XMTEXT="^TMP(""ORTXT"","_$JOB_","
DO ^XMD
+23 KILL ^TMP("ORTXT",$JOB)
+24 QUIT
+25 ;
PARAMS ; -- Remove old parameters, template
+1 ;
+2 NEW DA,DIK,ORI
+3 SET DIK="^XTV(8989.52,"
SET DA=+$ORDER(^XTV(8989.52,"B","ORP AUTODC ORDERS",0))
IF DA
DO ^DIK
+4 FOR ORI="OR DC GEN ORD ON ADMISSION","ORPF DC OF GENERIC ORDERS","OR DC ON SPEC CHANGE","OR DELAYED ORDERS LAPSE DAYS"
Begin DoDot:1
+5 SET DIK="^XTV(8989.51,"
SET DA=+$ORDER(^XTV(8989.51,"B",ORI,0))
+6 IF DA
DO ^DIK
End DoDot:1
+7 QUIT
+8 ;
DLGS ; -- Send bulletin re modified dialogs
+1 NEW I,ORD
+2 FOR I="LR OTHER LAB TESTS","RA OERR EXAM","PS MEDS","PSJ OR PAT OE","PSO OERR","PSO SUPPLY","OR GXMOVE ADMIT PATIENT","OR GXMOVE DISCHARGE","OR GXMOVE TRANSFER","OR GXMOVE TREATING SPECIALTY"
SET ORD(I)=""
+3 DO EN^ORYDLG(141,.ORD)
+4 QUIT
+5 ;
101 ; -- replace items on protocol menus
+1 NEW ORI,ORX,ORMENU,OROLD,ORNEW,ORMNEM,DA,DR,DIE,X,Y
+2 FOR ORI=1:1
SET ORX=$TEXT(PRTCLS+ORI)
IF ORX["ZZZZZ"
QUIT
Begin DoDot:1
+3 SET ORMENU=+$ORDER(^ORD(101,"B",$PIECE(ORX,";",3),0))
IF ORMENU<1
QUIT
+4 SET OROLD=+$ORDER(^ORD(101,"B",$PIECE(ORX,";",4),0))
IF OROLD<1
QUIT
+5 ;already fixed
SET DA=+$ORDER(^ORD(101,ORMENU,10,"B",OROLD,0))
IF DA<1
QUIT
+6 SET ORNEW=$PIECE(ORX,";",5)
SET ORMNEM=$PIECE(ORX,";",6)
+7 SET DIE="^ORD(101,"_ORMENU_",10,"
SET DA(1)=ORMENU
+8 SET DR=".01///^S X=ORNEW;2///^S X=ORMNEM;5///@;6///@"
DO ^DIE
End DoDot:1
+9 QUIT
+10 ;
PRTCLS ;;MENU;REPL;WITH;MNEMONIC
+1 ;;ORCHART ORDERS MENU;ORB BLANK LINE1;ORC DELAYED ORDERS;TD
+2 ;;ORC ADD ORDERS MENU;ORC EVENT MENU;VALM PREVIOUS SCREEN;-
+3 ;;ZZZZZ
+4 ;
C ; -- Rebuild C index on #100.5 to uppercase
+1 NEW X,X1,DA
KILL ^TMP($JOB,"ORD100.5C")
+2 SET X=""
FOR
SET X=$ORDER(^ORD(100.5,"C",X))
IF X=""
QUIT
Begin DoDot:1
+3 SET X1=$$UP^XLFSTR(X)
SET DA=0
+4 FOR
SET DA=$ORDER(^ORD(100.5,"C",X,DA))
IF DA<1
QUIT
SET ^TMP($JOB,"ORD100.5C",X1,DA)=""
End DoDot:1
+5 KILL ^ORD(100.5,"C")
MERGE ^ORD(100.5,"C")=^TMP($JOB,"ORD100.5C")
+6 KILL ^TMP($JOB,"ORD100.5C")
+7 QUIT
