- 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