ORWDX3 ; SLC/STAFF - Order dialog utilities ;Apr 12, 2022@12:12:08
;;3.0;ORDER ENTRY/RESULTS REPORTING;**405**;Dec 17, 1997;Build 211
;Per VA Directive 6402, this routine should not be modified.
;
;Reference to DIC(9.4 supported by IA #2058
;Reference to ^DPT( supported by ICR #10035
;
Q
;
SAVE ; From SAVE^ORWDX - moved here because of routine size. (Don't call into this tag directly. Call into SAVE^ORWDX).
N ORDUZ,ORSTS,OREVENT,ORCAT,ORDA,ORTS,ORNEW,ORCHECK,ORLOG,ORLEAD,ORTRAIL,ORPKG,ORWP94,ORCATFN,OREVTYPE,ONPASS,OROVER,ORAGYCNT,ORAGY,ORCHKCNT,ORRCOMM
N MSGCAPT,SENDMSG,NUM,ORALLGY,ORALLXST,ORALLCHKNM,ORDOI
N XCNT,XCOMM,XDONE,XX ;SBR
S (XCOMM,XCNT)="" ;SBR
I $G(ORIFN)'="" D ;SBR problem only occurs on change or renew orders
. S XCNT=$O(^OR(100,+ORIFN,4.5,"ID","COMMENT",XCNT)) ;SBR
. I XCNT'="" S XCOMM=$P($G(^OR(100,+ORIFN,4.5,XCNT,0)),"^",2) ;SBR
. I XCOMM'="" S XDONE=0,XX="" F S XX=$O(ORDIALOG("WP",XCOMM,1,XX)) Q:XX="" D ;SBR
. . I ORDIALOG("WP",XCOMM,1,XX,0)'="" S XDONE=1 Q ;SBR
. I XCOMM'="",'$G(XDONE),$D(ORDIALOG("WP",XCOMM)) K ORDIALOG("WP",XCOMM) ;SBR
S ORDOI=+$G(ORDIALOG(4,1))
S ORCATFN="" I $L($P(DLG,U,2)) S ORCATFN=$P(DLG,U,2),DLG=$P(DLG,U,1)
S SENDMSG=0 I $P($G(^ORD(100.98,ORDG,0)),U)="INPATIENT MEDICATIONS" D
.Q:("^PSJ OR PAT OE^PSJI OR PAT FLUID OE^PSJ OR CLINIC OE^CLINIC OR PAT FLUID OE^"'[(U_DLG_U))
.S MSGCAPT("PATIENT")=ORVP,MSGCAPT("USER")=ORNP,MSGCAPT("LOC")=+$G(ORL)
.S MSGCAPT("DIALOG")=DLG,MSGCAPT("DISPLAY GROUP")=ORDG,MSGCAPT("QUICK ORDER")=ORIT
.M MSGCAPT("ORDIALOG")=ORDIALOG
.N NEWORDG S NEWORDG=$S(DLG="PSJI OR PAT FLUID OE":"IV MEDICATIONS",DLG="PSJ OR CLINIC OE":"CLINIC MEDICATIONS",DLG="CLINIC OR PAT FLUID OE":"CLINIC INFUSIONS",1:"UNIT DOSE MEDICATIONS")
.S ORDG=$O(^ORD(100.98,"B",NEWORDG,"")),SENDMSG=1
;Remove treating facility if inpatient and IMO order 26.42
I $G(^DPT(ORVP,.1))'="",$P($G(^ORD(100.98,ORDG,0)),U)="CLINIC MEDICATIONS" K ORDIALOG("ORTS")
I $G(^DPT(ORVP,.1))'="",$P($G(^ORD(100.98,ORDG,0)),U)="CLINIC INFUSIONS" K ORDIALOG("ORTS")
I $G(ORDIALOG("ORTS")) S ORTS=ORDIALOG("ORTS") K ORDIALOG("ORTS")
I $G(ORDIALOG("ORSLOG")) S ORLOG=ORDIALOG("ORSLOG") K ORDIALOG("ORSLOG")
I $D(ORDIALOG("OREVENT")) S OREVENT=ORDIALOG("OREVENT") K ORDIALOG("OREVENT")
I $D(ORDIALOG("OVERRIDE")) S OROVER=ORDIALOG("OVERRIDE") K ORDIALOG("OVERRIDE")
I $D(ORDIALOG("ORREMCOMMENT")) S ORRCOMM=ORDIALOG("ORREMCOMMENT") K ORDIALOG("ORREMCOMMENT")
;=====================================================
; Changed for v26.27 (RV)
S ORCAT=$$INPT^ORCD,ORCAT=$S(ORCAT=1:"I",1:"O")
;I $L($G(OREVENT)) D
;. S ONPASS=0
;. S OREVTYPE=$$TYPE^OREVNTX(OREVENT)
;. I OREVTYPE="T" D ISPASS^OREVNTX1(.ONPASS,+OREVENT,"T")
;. S ORCAT=$S(OREVTYPE="A":"I",OREVTYPE="T":"I",ONPASS=1:"O",1:"O")
;E S ORCAT=$S($L($P($G(^DPT(+ORVP,.1)),U)):"I",1:"O")
;=====================================================
I DLG="PS MEDS" S ORWP94=1 D
. I ORIT=$O(^ORD(101.41,"AB","PSO SUPPLY",0)) S DLG="PSO SUPPLY"
. I ORIT=$O(^ORD(101.41,"AB","PSO OERR",0)) S DLG="PSO OERR"
. I ORIT=$O(^ORD(101.41,"AB","PSJ OR PAT OE",0)) S DLG="PSJ OR PAT OE"
I DLG="PSO OERR"!(DLG="PSO SUPPLY") S ORCAT="O" I $G(OREVENT("EFFECTIVE")) D
. S ORDIALOG($O(^ORD(101.41,"B","OR GTX START DATE"_$S($G(ORWP94):"/TIME",1:""),0)),1)=OREVENT("EFFECTIVE")
I DLG="PSO OERR" D
. N DRUGPRMT,OIPRMT,ORDRUG,OROI
. S DRUGPRMT=+$O(^ORD(101.41,"B","OR GTX DISPENSE DRUG",0))
. S ORDRUG=$G(ORDIALOG(DRUGPRMT,1))
. I ORDRUG,$$ISSUPPLY^ORUTL3(ORDRUG) D
. . S ORDG=+$O(^ORD(100.98,"B","SUPPLIES/DEVICES",0))
. S OIPRMT=+$O(^ORD(101.41,"B","OR GTX ORDERABLE ITEM",0))
. S OROI=$G(ORDIALOG(OIPRMT,1))
. I 'ORDRUG,OROI,$$ISOISPLY^ORUTL3(OROI) D
. . S ORDG=+$O(^ORD(100.98,"B","SUPPLIES/DEVICES",0))
I DLG="PSJ OR PAT OE" S ORCAT="I"
I DLG="PSJ OR CLINIC OE" S ORCAT="I"
I DLG="CLINIC OR PAT FLUID OE" S ORCAT="I"
S:DLG="FHW1" ORCAT="I" S:DLG?1"FHW "2.7U1" MEAL" ORCAT="O"
S ORVP=ORVP_";DPT(",ORL(2)=ORL_";SC(",ORL=ORL(2)
I ORDG=$O(^ORD(100.98,"B","LAB",0)) D ;use section
. N OI,SUB S OI=+$G(ORDIALOG($$PTR^ORCD("OR GTX ORDERABLE ITEM"),1))
. S SUB=$P($G(^ORD(101.43,OI,"LR")),U,6),ORDG=$$DGRP^ORMLR(SUB)
I ORDG=$O(^ORD(100.98,"B","AP",0)) D ;provides orders sort for AP orders by SP, CY and EM
. N OI,SUB S OI=+$G(ORDIALOG($$PTR^ORCD("OR GTX ORDERABLE ITEM"),1))
. S SUB=$P($G(^ORD(101.43,OI,"LR")),U,6),ORDG=$$DGRP^ORMLR(SUB)
K:'ORDG ORDG K:'ORIT ORIT ; Dgrp & Quick must be non-zero
M ORCHECK=ORDIALOG("ORCHECK") K ORDIALOG("ORCHECK")
S ORALLGY=$O(^ORD(100.8,"B","ALLERGY-DRUG INTERACTION",0))
I '$G(DT) S DT=$$DT^XLFDT
S ORALLCHKNM="ORALLERGYCHK"
I '$D(^TMP(ORALLCHKNM,$J,+ORVP,+ORDOI)),$D(^ORD(100.05,"C",+$G(ORIFN),"ACCEPTANCE_CPRS")) D
. N ORAGY,ORCHK,ORDCHK,ORDRGLOC,ORMSG,ORSVR
. I $G(OROVER)="" S OROVER="No override reason given"
. S (NUM,ORAGY)=0
. ;F S ORAGY=$O(^ORD(100.05,"C",+$G(ORIFN),"ACCEPTANCE_CPRS",ORAGY)) Q:ORAGY="" D
. ;. S ORDCHK(1)=$G(^ORD(100.05,ORAGY,1))
. ;. S ORDCHK(4)=$G(^ORD(100.05,ORAGY,4,1,0))
. ;. I ORALLGY'=$P(ORDCHK(1),U,1) Q ;ALLERGY-DRUG INTERACTION only
. ;. S ORSVR=$P(ORDCHK(1),U,2) ;Severity
. ;. S ORMSG=$G(^ORD(100.05,ORAGY,2,1,0))
. ;. S ORCHKCNT=ORCHECK
. ;. N CDL
. ;. S CDL="" F S CDL=$O(ORCHECK("NEW",CDL)) Q:CDL="" D
. ;. . I $O(ORCHECK("NEW",CDL,""),-1)>ORCHKCNT S ORCHKCNT=$O(ORCHECK("NEW",CDL,""),-1)
. ;. S ORCHECK("NEW",1,$I(ORCHKCNT))=ORALLGY_U_ORSVR_U_ORMSG
. ;. S ORCHECK("NEW",1,ORCHKCNT,"OVER")=OROVER
. ;. S ORCHECK=ORCHECK+1
. ;. I $G(ORRCOMM)]"",$P(ORDCHK(4),U,3)="R" D
. ;. . S ORDRGLOC=$P(ORDCHK(4),U,4)_";"_$P(ORDCHK(4),U,1)
. ;. . S ORCHECK("NEW",1,ORCHKCNT,"REMCOMM")=ORRCOMM
. ;. . D SAVRCOM(ORVP,ORDRGLOC,ORRCOMM)
. ;. ;SAVE DATA FOR ORDER CHECK INSTANCES FILE ENTRY (Create as if allergy order checks ran)
. ;. N CLASS,CRC16,ING,ITM,NODE,SIGN
. ;. S CRC16=$$CRC16^XLFCRC(ORMSG)
. ;. S NUM=1+$G(NUM)
. ;. K:NUM=1 ^TMP("OROCIDATA",$J,CRC16)
. ;. S ^TMP("OROCIDATA",$J,CRC16,100.517,NUM,.01)=$P(ORDCHK(4),U,1) ;$P(DATA(J,ITM),U,6)
. ;. S:$P(ORDCHK(4),U,2)'="" ^TMP("OROCIDATA",$J,CRC16,100.517,NUM,2)=$P(ORDCHK(4),U,2) ;$P(DATA(J,ITM),U,7)
. ;. S ^TMP("OROCIDATA",$J,CRC16,100.517,NUM,6)=$P(ORDCHK(4),U,3) ;$P(DATA(J,ITM),U,2)
. ;. S:$P(ORDCHK(4),U,4)="R" ^TMP("OROCIDATA",$J,CRC16,100.517,NUM,7)=$P(ORDCHK(4),U,4) ;$P(DATA(J,ITM),U)
. ;. S ^TMP("OROCIDATA",$J,CRC16,100.517,NUM,8)=$P(ORDCHK(4),U,5) ;$P(DATA(J,ITM),U,3)
. ;. S ^TMP("OROCIDATA",$J,CRC16,100.517,NUM,9)=$P(ORDCHK(4),U,6) ;$$UP^XLFSTR($P(DATA(J,ITM),U,8))
. ;. S:$P(ORDCHK(4),U,1)'="" ^TMP("OROCIDATA",$J,CRC16,100.517,NUM,10)=$P(ORDCHK(4),U,1) ;SEVERE("MSG")
. ;. S ^TMP("OROCIDATA",$J,CRC16,100.517,NUM,11)=$G(^ORD(100.05,ORAGY,4,1,4)) ;$P(DATA(J,ITM),U,10)
. ;. S (ITM(1),SIGN)=0
. ;. F S SIGN=$O(^ORD(100.05,ORAGY,4,1,3,"B",SIGN)) Q:+SIGN=0 D
. ;. . S ITM(1)=$G(ITM(1))+1
. ;. . S ^TMP("OROCIDATA",$J,CRC16,"SIGN",NUM,"+"_ITM(1)_",")=SIGN
. ;. S ^TMP("OROCIDATA",$J,CRC16,100.05,84)=$P($G(^ORD(100.05,ORAGY,8)),U,4)
. ;. S CLASS=0
. ;. F S CLASS=$O(^ORD(100.05,ORAGY,4,1,1,"B",CLASS)) Q:+CLASS=0 D
. ;. . S ITM(1)=$G(ITM(1))+1
. ;. . S ^TMP("OROCIDATA",$J,CRC16,"CLASS",NUM,"+"_ITM(1)_",")=CLASS
. ;. S ING=0
. ;. F S ING=$O(^ORD(100.05,ORAGY,4,1,2,"B",ING)) Q:+ING=0 D
. ;. . S ITM(1)=$G(ITM(1))+1
. ;. . S ^TMP("OROCIDATA",$J,CRC16,"INGREDIENT",NUM,"+"_ITM(1)_",")=ING
S ORALLXST=0
I $D(^TMP(ORALLCHKNM,$J,+ORVP,+ORDOI)) D
. N ORCHKCNT,ORCHKSVR,ORTMPCHK
. S ORCHKSVR=0
. F S ORCHKSVR=$O(ORCHECK("NEW",ORCHKSVR)) Q:ORCHKSVR="" D Q:ORALLXST
. . S ORCHKCNT=0
. . F S ORCHKCNT=$O(ORCHECK("NEW",ORCHKSVR,ORCHKCNT)) Q:ORCHKCNT="" D Q:ORALLXST
. . . I $P($G(ORCHECK("NEW",ORCHKSVR,ORCHKCNT)),U,1)'=ORALLGY Q
. . . S ORALLXST=1
. I ORALLXST Q
. I $G(OROVER)="" S OROVER="No override reason given"
. S ORCHKCNT=ORCHECK,ORAGYCNT=$O(^TMP(ORALLCHKNM,$J,+ORVP,+ORDOI,""),-1),ORCHECK=ORCHECK+ORAGYCNT
. N CDL
. S CDL="" F S CDL=$O(ORCHECK("NEW",CDL)) Q:CDL="" D
. . I $O(ORCHECK("NEW",CDL,""),-1)>ORCHKCNT S ORCHKCNT=$O(ORCHECK("NEW",CDL,""),-1)
. F ORAGY=1:1:ORAGYCNT D
. . S ORTMPCHK=$G(^TMP(ORALLCHKNM,$J,+ORVP,+ORDOI,ORAGY))
. . S ORCHECK("NEW",1,$I(ORCHKCNT))=$P(ORTMPCHK,U,2,4)
. . S ORCHECK("NEW",1,ORCHKCNT,"OVER")=OROVER
. . I $G(ORRCOMM)]"",$P(ORTMPCHK,U,5)=1 D
. . . S ORCHECK("NEW",1,ORCHKCNT,"REMCOMM")=ORRCOMM
. . . D SAVRCOM(ORVP,$P(ORTMPCHK,U,6),ORRCOMM)
I ORALLXST=1 D
. N ORCHKCNT,ORCHKSVR
. S ORCHKSVR=0
. F S ORCHKSVR=$O(ORCHECK("NEW",ORCHKSVR)) Q:ORCHKSVR="" D
. . S ORCHKCNT=0
. . F S ORCHKCNT=$O(ORCHECK("NEW",ORCHKSVR,ORCHKCNT)) Q:ORCHKCNT="" D
. . . I $P($G(ORCHECK("NEW",ORCHKSVR,ORCHKCNT)),U,1)'=ORALLGY Q
. . . I $G(OROVER)="" S OROVER="No override reason given"
. . . S ORCHECK("NEW",ORCHKSVR,ORCHKCNT,"OVER")=OROVER
. . . S ORTMPCHK=$G(^TMP(ORALLCHKNM,$J,+ORVP,+ORDOI,ORCHKCNT))
. . . I $G(ORRCOMM)]"",$P(ORTMPCHK,U,5)=1 D
. . . . S ORCHECK("NEW",ORCHKSVR,ORCHKCNT,"REMCOMM")=ORRCOMM
. . . . D SAVRCOM(ORVP,$P(ORTMPCHK,U,6),ORRCOMM)
D CLRALLGY^ORWDXC("",+ORVP)
S ORDIALOG=$O(^ORD(101.41,"AB",DLG,0))
I 'ORDIALOG S ORDIALOG=$O(^ORD(101.41,"B",DLG,0))
I $D(ORDIALOG("ORLEAD")) S ORLEAD=ORDIALOG("ORLEAD")
I $D(ORDIALOG("ORTRAIL")) S ORTRAIL=ORDIALOG("ORTRAIL")
D GETDLG1^ORCD(ORDIALOG)
I $L(ORCATFN) S ORCAT=ORCATFN
I $G(ORWP94) D
. N SIGPRMT S SIGPRMT=$O(^ORD(101.41,"B","OR GTX SIG",0))
. N INSPRMT S INSPRMT=$O(^ORD(101.41,"B","OR GTX INSTRUCTIONS",0))
. I $L($G(ORDIALOG(SIGPRMT,1))) S ORDIALOG(INSPRMT,"FORMAT")="@"
. I ORCAT="O" S ORPKG=$O(^DIC(9.4,"C","PSO",0))
. I ORCAT="I" S ORPKG=$O(^DIC(9.4,"C","PSJ",0))
S ORSRC=$G(ORSRC)
D DELPI^ORWDX1 ;delete empty PI
I $G(ORIFN)="" D ; new order
. D EN^ORCSAVE
. S REC="" I ORIFN D GETBYIFN^ORWORR(.REC,ORIFN)
. I '$D(^TMP("ORECALL",$J,ORDIALOG)) M ^TMP("ORECALL",$J,ORDIALOG)=ORDIALOG
E D
. N OR0
. S OR0=$G(^OR(100,+ORIFN,0)),ORSTS=$P($G(^(3)),U,3),ORDG=$P(OR0,U,11)
. I $L($P(OR0,U,17)),ORSTS=10 S OREVENT=$P(OR0,U,17),OREVENT("TS")=$P(OR0,U,13)
. D XX^ORCSAVE ; edit order
. S REC="" S ORIFN=+ORIFN_";"_ORDA D GETBYIFN^ORWORR(.REC,ORIFN)
I SENDMSG D
.S MSGCAPT("ORIGINAL IEN")=$G(ORIFN)
.D MSG^ORUTL5(REC,.MSGCAPT)
D:DLG="GMRCOR CONSULT" CHKAUTO^ORCSLT
D DELORC^ORNORC(ORVP,.ORDIALOG) ; ajb remove order check info from 100.3
Q
;
;
SAVRCOM(ORVP,AREC,RCOMM) ;Save Local Comment to Remote Allergy
;AREC: This will contain the allergy record identifier (RECID)
; and the original comment presented to the user (PREVCOMM)
N GMR,RECID,PREVCOMM,COMREC,DA,COMMID,LASTCOMM
S RECID=$P(AREC,"~"),PREVCOMM=$P(AREC,"~",2,99)
S DIC="^GMR(120.88,",DIC(0)="F"
S DIE=DIC,LASTCOMM=""
S COMMID=$O(^GMR(120.88,"PR",ORVP,RECID,""),-1)
I COMMID]"" S LASTCOMM=$G(^GMR(120.88,COMMID,1))
Q:LASTCOMM=RCOMM
S DA(.01)=RECID,DA(.02)=ORVP,DA(.03)=$$NOW^XLFDT(),DA(.04)=DUZ,DA(1)=RCOMM
M GMR(120.88,"+1,")=DA
D UPDATE^DIE("","GMR",,"ERROR")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORWDX3 11051 printed Dec 13, 2024@02:35:53 Page 2
ORWDX3 ; SLC/STAFF - Order dialog utilities ;Apr 12, 2022@12:12:08
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**405**;Dec 17, 1997;Build 211
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;Reference to DIC(9.4 supported by IA #2058
+5 ;Reference to ^DPT( supported by ICR #10035
+6 ;
+7 QUIT
+8 ;
SAVE ; From SAVE^ORWDX - moved here because of routine size. (Don't call into this tag directly. Call into SAVE^ORWDX).
+1 NEW ORDUZ,ORSTS,OREVENT,ORCAT,ORDA,ORTS,ORNEW,ORCHECK,ORLOG,ORLEAD,ORTRAIL,ORPKG,ORWP94,ORCATFN,OREVTYPE,ONPASS,OROVER,ORAGYCNT,ORAGY,ORCHKCNT,ORRCOMM
+2 NEW MSGCAPT,SENDMSG,NUM,ORALLGY,ORALLXST,ORALLCHKNM,ORDOI
+3 ;SBR
NEW XCNT,XCOMM,XDONE,XX
+4 ;SBR
SET (XCOMM,XCNT)=""
+5 ;SBR problem only occurs on change or renew orders
IF $GET(ORIFN)'=""
Begin DoDot:1
+6 ;SBR
SET XCNT=$ORDER(^OR(100,+ORIFN,4.5,"ID","COMMENT",XCNT))
+7 ;SBR
IF XCNT'=""
SET XCOMM=$PIECE($GET(^OR(100,+ORIFN,4.5,XCNT,0)),"^",2)
+8 ;SBR
IF XCOMM'=""
SET XDONE=0
SET XX=""
FOR
SET XX=$ORDER(ORDIALOG("WP",XCOMM,1,XX))
if XX=""
QUIT
Begin DoDot:2
+9 ;SBR
IF ORDIALOG("WP",XCOMM,1,XX,0)'=""
SET XDONE=1
QUIT
End DoDot:2
+10 ;SBR
IF XCOMM'=""
IF '$GET(XDONE)
IF $DATA(ORDIALOG("WP",XCOMM))
KILL ORDIALOG("WP",XCOMM)
End DoDot:1
+11 SET ORDOI=+$GET(ORDIALOG(4,1))
+12 SET ORCATFN=""
IF $LENGTH($PIECE(DLG,U,2))
SET ORCATFN=$PIECE(DLG,U,2)
SET DLG=$PIECE(DLG,U,1)
+13 SET SENDMSG=0
IF $PIECE($GET(^ORD(100.98,ORDG,0)),U)="INPATIENT MEDICATIONS"
Begin DoDot:1
+14 if ("^PSJ OR PAT OE^PSJI OR PAT FLUID OE^PSJ OR CLINIC OE^CLINIC OR PAT FLUID OE^"'[(U_DLG_U))
QUIT
+15 SET MSGCAPT("PATIENT")=ORVP
SET MSGCAPT("USER")=ORNP
SET MSGCAPT("LOC")=+$GET(ORL)
+16 SET MSGCAPT("DIALOG")=DLG
SET MSGCAPT("DISPLAY GROUP")=ORDG
SET MSGCAPT("QUICK ORDER")=ORIT
+17 MERGE MSGCAPT("ORDIALOG")=ORDIALOG
+18 NEW NEWORDG
SET NEWORDG=$SELECT(DLG="PSJI OR PAT FLUID OE":"IV MEDICATIONS",DLG="PSJ OR CLINIC OE":"CLINIC MEDICATIONS",DLG="CLINIC OR PAT FLUID OE":"CLINIC INFUSIONS",1:"UNIT DOSE MEDICATIONS")
+19 SET ORDG=$ORDER(^ORD(100.98,"B",NEWORDG,""))
SET SENDMSG=1
End DoDot:1
+20 ;Remove treating facility if inpatient and IMO order 26.42
+21 IF $GET(^DPT(ORVP,.1))'=""
IF $PIECE($GET(^ORD(100.98,ORDG,0)),U)="CLINIC MEDICATIONS"
KILL ORDIALOG("ORTS")
+22 IF $GET(^DPT(ORVP,.1))'=""
IF $PIECE($GET(^ORD(100.98,ORDG,0)),U)="CLINIC INFUSIONS"
KILL ORDIALOG("ORTS")
+23 IF $GET(ORDIALOG("ORTS"))
SET ORTS=ORDIALOG("ORTS")
KILL ORDIALOG("ORTS")
+24 IF $GET(ORDIALOG("ORSLOG"))
SET ORLOG=ORDIALOG("ORSLOG")
KILL ORDIALOG("ORSLOG")
+25 IF $DATA(ORDIALOG("OREVENT"))
SET OREVENT=ORDIALOG("OREVENT")
KILL ORDIALOG("OREVENT")
+26 IF $DATA(ORDIALOG("OVERRIDE"))
SET OROVER=ORDIALOG("OVERRIDE")
KILL ORDIALOG("OVERRIDE")
+27 IF $DATA(ORDIALOG("ORREMCOMMENT"))
SET ORRCOMM=ORDIALOG("ORREMCOMMENT")
KILL ORDIALOG("ORREMCOMMENT")
+28 ;=====================================================
+29 ; Changed for v26.27 (RV)
+30 SET ORCAT=$$INPT^ORCD
SET ORCAT=$SELECT(ORCAT=1:"I",1:"O")
+31 ;I $L($G(OREVENT)) D
+32 ;. S ONPASS=0
+33 ;. S OREVTYPE=$$TYPE^OREVNTX(OREVENT)
+34 ;. I OREVTYPE="T" D ISPASS^OREVNTX1(.ONPASS,+OREVENT,"T")
+35 ;. S ORCAT=$S(OREVTYPE="A":"I",OREVTYPE="T":"I",ONPASS=1:"O",1:"O")
+36 ;E S ORCAT=$S($L($P($G(^DPT(+ORVP,.1)),U)):"I",1:"O")
+37 ;=====================================================
+38 IF DLG="PS MEDS"
SET ORWP94=1
Begin DoDot:1
+39 IF ORIT=$ORDER(^ORD(101.41,"AB","PSO SUPPLY",0))
SET DLG="PSO SUPPLY"
+40 IF ORIT=$ORDER(^ORD(101.41,"AB","PSO OERR",0))
SET DLG="PSO OERR"
+41 IF ORIT=$ORDER(^ORD(101.41,"AB","PSJ OR PAT OE",0))
SET DLG="PSJ OR PAT OE"
End DoDot:1
+42 IF DLG="PSO OERR"!(DLG="PSO SUPPLY")
SET ORCAT="O"
IF $GET(OREVENT("EFFECTIVE"))
Begin DoDot:1
+43 SET ORDIALOG($ORDER(^ORD(101.41,"B","OR GTX START DATE"_$SELECT($GET(ORWP94):"/TIME",1:""),0)),1)=OREVENT("EFFECTIVE")
End DoDot:1
+44 IF DLG="PSO OERR"
Begin DoDot:1
+45 NEW DRUGPRMT,OIPRMT,ORDRUG,OROI
+46 SET DRUGPRMT=+$ORDER(^ORD(101.41,"B","OR GTX DISPENSE DRUG",0))
+47 SET ORDRUG=$GET(ORDIALOG(DRUGPRMT,1))
+48 IF ORDRUG
IF $$ISSUPPLY^ORUTL3(ORDRUG)
Begin DoDot:2
+49 SET ORDG=+$ORDER(^ORD(100.98,"B","SUPPLIES/DEVICES",0))
End DoDot:2
+50 SET OIPRMT=+$ORDER(^ORD(101.41,"B","OR GTX ORDERABLE ITEM",0))
+51 SET OROI=$GET(ORDIALOG(OIPRMT,1))
+52 IF 'ORDRUG
IF OROI
IF $$ISOISPLY^ORUTL3(OROI)
Begin DoDot:2
+53 SET ORDG=+$ORDER(^ORD(100.98,"B","SUPPLIES/DEVICES",0))
End DoDot:2
End DoDot:1
+54 IF DLG="PSJ OR PAT OE"
SET ORCAT="I"
+55 IF DLG="PSJ OR CLINIC OE"
SET ORCAT="I"
+56 IF DLG="CLINIC OR PAT FLUID OE"
SET ORCAT="I"
+57 if DLG="FHW1"
SET ORCAT="I"
if DLG?1"FHW "2.7U1" MEAL"
SET ORCAT="O"
+58 SET ORVP=ORVP_";DPT("
SET ORL(2)=ORL_";SC("
SET ORL=ORL(2)
+59 ;use section
IF ORDG=$ORDER(^ORD(100.98,"B","LAB",0))
Begin DoDot:1
+60 NEW OI,SUB
SET OI=+$GET(ORDIALOG($$PTR^ORCD("OR GTX ORDERABLE ITEM"),1))
+61 SET SUB=$PIECE($GET(^ORD(101.43,OI,"LR")),U,6)
SET ORDG=$$DGRP^ORMLR(SUB)
End DoDot:1
+62 ;provides orders sort for AP orders by SP, CY and EM
IF ORDG=$ORDER(^ORD(100.98,"B","AP",0))
Begin DoDot:1
+63 NEW OI,SUB
SET OI=+$GET(ORDIALOG($$PTR^ORCD("OR GTX ORDERABLE ITEM"),1))
+64 SET SUB=$PIECE($GET(^ORD(101.43,OI,"LR")),U,6)
SET ORDG=$$DGRP^ORMLR(SUB)
End DoDot:1
+65 ; Dgrp & Quick must be non-zero
if 'ORDG
KILL ORDG
if 'ORIT
KILL ORIT
+66 MERGE ORCHECK=ORDIALOG("ORCHECK")
KILL ORDIALOG("ORCHECK")
+67 SET ORALLGY=$ORDER(^ORD(100.8,"B","ALLERGY-DRUG INTERACTION",0))
+68 IF '$GET(DT)
SET DT=$$DT^XLFDT
+69 SET ORALLCHKNM="ORALLERGYCHK"
+70 IF '$DATA(^TMP(ORALLCHKNM,$JOB,+ORVP,+ORDOI))
IF $DATA(^ORD(100.05,"C",+$GET(ORIFN),"ACCEPTANCE_CPRS"))
Begin DoDot:1
+71 NEW ORAGY,ORCHK,ORDCHK,ORDRGLOC,ORMSG,ORSVR
+72 IF $GET(OROVER)=""
SET OROVER="No override reason given"
+73 SET (NUM,ORAGY)=0
+74 ;F S ORAGY=$O(^ORD(100.05,"C",+$G(ORIFN),"ACCEPTANCE_CPRS",ORAGY)) Q:ORAGY="" D
+75 ;. S ORDCHK(1)=$G(^ORD(100.05,ORAGY,1))
+76 ;. S ORDCHK(4)=$G(^ORD(100.05,ORAGY,4,1,0))
+77 ;. I ORALLGY'=$P(ORDCHK(1),U,1) Q ;ALLERGY-DRUG INTERACTION only
+78 ;. S ORSVR=$P(ORDCHK(1),U,2) ;Severity
+79 ;. S ORMSG=$G(^ORD(100.05,ORAGY,2,1,0))
+80 ;. S ORCHKCNT=ORCHECK
+81 ;. N CDL
+82 ;. S CDL="" F S CDL=$O(ORCHECK("NEW",CDL)) Q:CDL="" D
+83 ;. . I $O(ORCHECK("NEW",CDL,""),-1)>ORCHKCNT S ORCHKCNT=$O(ORCHECK("NEW",CDL,""),-1)
+84 ;. S ORCHECK("NEW",1,$I(ORCHKCNT))=ORALLGY_U_ORSVR_U_ORMSG
+85 ;. S ORCHECK("NEW",1,ORCHKCNT,"OVER")=OROVER
+86 ;. S ORCHECK=ORCHECK+1
+87 ;. I $G(ORRCOMM)]"",$P(ORDCHK(4),U,3)="R" D
+88 ;. . S ORDRGLOC=$P(ORDCHK(4),U,4)_";"_$P(ORDCHK(4),U,1)
+89 ;. . S ORCHECK("NEW",1,ORCHKCNT,"REMCOMM")=ORRCOMM
+90 ;. . D SAVRCOM(ORVP,ORDRGLOC,ORRCOMM)
+91 ;. ;SAVE DATA FOR ORDER CHECK INSTANCES FILE ENTRY (Create as if allergy order checks ran)
+92 ;. N CLASS,CRC16,ING,ITM,NODE,SIGN
+93 ;. S CRC16=$$CRC16^XLFCRC(ORMSG)
+94 ;. S NUM=1+$G(NUM)
+95 ;. K:NUM=1 ^TMP("OROCIDATA",$J,CRC16)
+96 ;. S ^TMP("OROCIDATA",$J,CRC16,100.517,NUM,.01)=$P(ORDCHK(4),U,1) ;$P(DATA(J,ITM),U,6)
+97 ;. S:$P(ORDCHK(4),U,2)'="" ^TMP("OROCIDATA",$J,CRC16,100.517,NUM,2)=$P(ORDCHK(4),U,2) ;$P(DATA(J,ITM),U,7)
+98 ;. S ^TMP("OROCIDATA",$J,CRC16,100.517,NUM,6)=$P(ORDCHK(4),U,3) ;$P(DATA(J,ITM),U,2)
+99 ;. S:$P(ORDCHK(4),U,4)="R" ^TMP("OROCIDATA",$J,CRC16,100.517,NUM,7)=$P(ORDCHK(4),U,4) ;$P(DATA(J,ITM),U)
+100 ;. S ^TMP("OROCIDATA",$J,CRC16,100.517,NUM,8)=$P(ORDCHK(4),U,5) ;$P(DATA(J,ITM),U,3)
+101 ;. S ^TMP("OROCIDATA",$J,CRC16,100.517,NUM,9)=$P(ORDCHK(4),U,6) ;$$UP^XLFSTR($P(DATA(J,ITM),U,8))
+102 ;. S:$P(ORDCHK(4),U,1)'="" ^TMP("OROCIDATA",$J,CRC16,100.517,NUM,10)=$P(ORDCHK(4),U,1) ;SEVERE("MSG")
+103 ;. S ^TMP("OROCIDATA",$J,CRC16,100.517,NUM,11)=$G(^ORD(100.05,ORAGY,4,1,4)) ;$P(DATA(J,ITM),U,10)
+104 ;. S (ITM(1),SIGN)=0
+105 ;. F S SIGN=$O(^ORD(100.05,ORAGY,4,1,3,"B",SIGN)) Q:+SIGN=0 D
+106 ;. . S ITM(1)=$G(ITM(1))+1
+107 ;. . S ^TMP("OROCIDATA",$J,CRC16,"SIGN",NUM,"+"_ITM(1)_",")=SIGN
+108 ;. S ^TMP("OROCIDATA",$J,CRC16,100.05,84)=$P($G(^ORD(100.05,ORAGY,8)),U,4)
+109 ;. S CLASS=0
+110 ;. F S CLASS=$O(^ORD(100.05,ORAGY,4,1,1,"B",CLASS)) Q:+CLASS=0 D
+111 ;. . S ITM(1)=$G(ITM(1))+1
+112 ;. . S ^TMP("OROCIDATA",$J,CRC16,"CLASS",NUM,"+"_ITM(1)_",")=CLASS
+113 ;. S ING=0
+114 ;. F S ING=$O(^ORD(100.05,ORAGY,4,1,2,"B",ING)) Q:+ING=0 D
+115 ;. . S ITM(1)=$G(ITM(1))+1
+116 ;. . S ^TMP("OROCIDATA",$J,CRC16,"INGREDIENT",NUM,"+"_ITM(1)_",")=ING
End DoDot:1
+117 SET ORALLXST=0
+118 IF $DATA(^TMP(ORALLCHKNM,$JOB,+ORVP,+ORDOI))
Begin DoDot:1
+119 NEW ORCHKCNT,ORCHKSVR,ORTMPCHK
+120 SET ORCHKSVR=0
+121 FOR
SET ORCHKSVR=$ORDER(ORCHECK("NEW",ORCHKSVR))
if ORCHKSVR=""
QUIT
Begin DoDot:2
+122 SET ORCHKCNT=0
+123 FOR
SET ORCHKCNT=$ORDER(ORCHECK("NEW",ORCHKSVR,ORCHKCNT))
if ORCHKCNT=""
QUIT
Begin DoDot:3
+124 IF $PIECE($GET(ORCHECK("NEW",ORCHKSVR,ORCHKCNT)),U,1)'=ORALLGY
QUIT
+125 SET ORALLXST=1
End DoDot:3
if ORALLXST
QUIT
End DoDot:2
if ORALLXST
QUIT
+126 IF ORALLXST
QUIT
+127 IF $GET(OROVER)=""
SET OROVER="No override reason given"
+128 SET ORCHKCNT=ORCHECK
SET ORAGYCNT=$ORDER(^TMP(ORALLCHKNM,$JOB,+ORVP,+ORDOI,""),-1)
SET ORCHECK=ORCHECK+ORAGYCNT
+129 NEW CDL
+130 SET CDL=""
FOR
SET CDL=$ORDER(ORCHECK("NEW",CDL))
if CDL=""
QUIT
Begin DoDot:2
+131 IF $ORDER(ORCHECK("NEW",CDL,""),-1)>ORCHKCNT
SET ORCHKCNT=$ORDER(ORCHECK("NEW",CDL,""),-1)
End DoDot:2
+132 FOR ORAGY=1:1:ORAGYCNT
Begin DoDot:2
+133 SET ORTMPCHK=$GET(^TMP(ORALLCHKNM,$JOB,+ORVP,+ORDOI,ORAGY))
+134
*** ERROR ***
SET ORCHECK("NEW",1,$I(ORCHKCNT))=$PIECE(ORTMPCHK,U,2,4)
+135 SET ORCHECK("NEW",1,ORCHKCNT,"OVER")=OROVER
+136 IF $GET(ORRCOMM)]""
IF $PIECE(ORTMPCHK,U,5)=1
Begin DoDot:3
+137 SET ORCHECK("NEW",1,ORCHKCNT,"REMCOMM")=ORRCOMM
+138 DO SAVRCOM(ORVP,$PIECE(ORTMPCHK,U,6),ORRCOMM)
End DoDot:3
End DoDot:2
End DoDot:1
+139 IF ORALLXST=1
Begin DoDot:1
+140 NEW ORCHKCNT,ORCHKSVR
+141 SET ORCHKSVR=0
+142 FOR
SET ORCHKSVR=$ORDER(ORCHECK("NEW",ORCHKSVR))
if ORCHKSVR=""
QUIT
Begin DoDot:2
+143 SET ORCHKCNT=0
+144 FOR
SET ORCHKCNT=$ORDER(ORCHECK("NEW",ORCHKSVR,ORCHKCNT))
if ORCHKCNT=""
QUIT
Begin DoDot:3
+145 IF $PIECE($GET(ORCHECK("NEW",ORCHKSVR,ORCHKCNT)),U,1)'=ORALLGY
QUIT
+146 IF $GET(OROVER)=""
SET OROVER="No override reason given"
+147 SET ORCHECK("NEW",ORCHKSVR,ORCHKCNT,"OVER")=OROVER
+148 SET ORTMPCHK=$GET(^TMP(ORALLCHKNM,$JOB,+ORVP,+ORDOI,ORCHKCNT))
+149 IF $GET(ORRCOMM)]""
IF $PIECE(ORTMPCHK,U,5)=1
Begin DoDot:4
+150 SET ORCHECK("NEW",ORCHKSVR,ORCHKCNT,"REMCOMM")=ORRCOMM
+151 DO SAVRCOM(ORVP,$PIECE(ORTMPCHK,U,6),ORRCOMM)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+152 DO CLRALLGY^ORWDXC("",+ORVP)
+153 SET ORDIALOG=$ORDER(^ORD(101.41,"AB",DLG,0))
+154 IF 'ORDIALOG
SET ORDIALOG=$ORDER(^ORD(101.41,"B",DLG,0))
+155 IF $DATA(ORDIALOG("ORLEAD"))
SET ORLEAD=ORDIALOG("ORLEAD")
+156 IF $DATA(ORDIALOG("ORTRAIL"))
SET ORTRAIL=ORDIALOG("ORTRAIL")
+157 DO GETDLG1^ORCD(ORDIALOG)
+158 IF $LENGTH(ORCATFN)
SET ORCAT=ORCATFN
+159 IF $GET(ORWP94)
Begin DoDot:1
+160 NEW SIGPRMT
SET SIGPRMT=$ORDER(^ORD(101.41,"B","OR GTX SIG",0))
+161 NEW INSPRMT
SET INSPRMT=$ORDER(^ORD(101.41,"B","OR GTX INSTRUCTIONS",0))
+162 IF $LENGTH($GET(ORDIALOG(SIGPRMT,1)))
SET ORDIALOG(INSPRMT,"FORMAT")="@"
+163 IF ORCAT="O"
SET ORPKG=$ORDER(^DIC(9.4,"C","PSO",0))
+164 IF ORCAT="I"
SET ORPKG=$ORDER(^DIC(9.4,"C","PSJ",0))
End DoDot:1
+165 SET ORSRC=$GET(ORSRC)
+166 ;delete empty PI
DO DELPI^ORWDX1
+167 ; new order
IF $GET(ORIFN)=""
Begin DoDot:1
+168 DO EN^ORCSAVE
+169 SET REC=""
IF ORIFN
DO GETBYIFN^ORWORR(.REC,ORIFN)
+170 IF '$DATA(^TMP("ORECALL",$JOB,ORDIALOG))
MERGE ^TMP("ORECALL",$JOB,ORDIALOG)=ORDIALOG
End DoDot:1
+171 IF '$TEST
Begin DoDot:1
+172 NEW OR0
+173 SET OR0=$GET(^OR(100,+ORIFN,0))
SET ORSTS=$PIECE($GET(^(3)),U,3)
SET ORDG=$PIECE(OR0,U,11)
+174 IF $LENGTH($PIECE(OR0,U,17))
IF ORSTS=10
SET OREVENT=$PIECE(OR0,U,17)
SET OREVENT("TS")=$PIECE(OR0,U,13)
+175 ; edit order
DO XX^ORCSAVE
+176 SET REC=""
SET ORIFN=+ORIFN_";"_ORDA
DO GETBYIFN^ORWORR(.REC,ORIFN)
End DoDot:1
+177 IF SENDMSG
Begin DoDot:1
+178 SET MSGCAPT("ORIGINAL IEN")=$GET(ORIFN)
+179 DO MSG^ORUTL5(REC,.MSGCAPT)
End DoDot:1
+180 if DLG="GMRCOR CONSULT"
DO CHKAUTO^ORCSLT
+181 ; ajb remove order check info from 100.3
DO DELORC^ORNORC(ORVP,.ORDIALOG)
+182 QUIT
+183 ;
+184 ;
SAVRCOM(ORVP,AREC,RCOMM) ;Save Local Comment to Remote Allergy
+1 ;AREC: This will contain the allergy record identifier (RECID)
+2 ; and the original comment presented to the user (PREVCOMM)
+3 NEW GMR,RECID,PREVCOMM,COMREC,DA,COMMID,LASTCOMM
+4 SET RECID=$PIECE(AREC,"~")
SET PREVCOMM=$PIECE(AREC,"~",2,99)
+5 SET DIC="^GMR(120.88,"
SET DIC(0)="F"
+6 SET DIE=DIC
SET LASTCOMM=""
+7 SET COMMID=$ORDER(^GMR(120.88,"PR",ORVP,RECID,""),-1)
+8 IF COMMID]""
SET LASTCOMM=$GET(^GMR(120.88,COMMID,1))
+9 if LASTCOMM=RCOMM
QUIT
+10 SET DA(.01)=RECID
SET DA(.02)=ORVP
SET DA(.03)=$$NOW^XLFDT()
SET DA(.04)=DUZ
SET DA(1)=RCOMM
+11 MERGE GMR(120.88,"+1,")=DA
+12 DO UPDATE^DIE("","GMR",,"ERROR")
+13 QUIT
