- 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 Feb 19, 2025@00:02:26 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