Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: ORWDX3

ORWDX3.m

Go to the documentation of this file.
  1. 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
  1. ;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. ;Reference to DIC(9.4 supported by IA #2058
  1. ;Reference to ^DPT( supported by ICR #10035
  1. ;
  1. Q
  1. ;
  1. SAVE ; From SAVE^ORWDX - moved here because of routine size. (Don't call into this tag directly. Call into SAVE^ORWDX).
  1. N ORDUZ,ORSTS,OREVENT,ORCAT,ORDA,ORTS,ORNEW,ORCHECK,ORLOG,ORLEAD,ORTRAIL,ORPKG,ORWP94,ORCATFN,OREVTYPE,ONPASS,OROVER,ORAGYCNT,ORAGY,ORCHKCNT,ORRCOMM
  1. N MSGCAPT,SENDMSG,NUM,ORALLGY,ORALLXST,ORALLCHKNM,ORDOI
  1. N XCNT,XCOMM,XDONE,XX ;SBR
  1. S (XCOMM,XCNT)="" ;SBR
  1. I $G(ORIFN)'="" D ;SBR problem only occurs on change or renew orders
  1. . S XCNT=$O(^OR(100,+ORIFN,4.5,"ID","COMMENT",XCNT)) ;SBR
  1. . I XCNT'="" S XCOMM=$P($G(^OR(100,+ORIFN,4.5,XCNT,0)),"^",2) ;SBR
  1. . I XCOMM'="" S XDONE=0,XX="" F S XX=$O(ORDIALOG("WP",XCOMM,1,XX)) Q:XX="" D ;SBR
  1. . . I ORDIALOG("WP",XCOMM,1,XX,0)'="" S XDONE=1 Q ;SBR
  1. . I XCOMM'="",'$G(XDONE),$D(ORDIALOG("WP",XCOMM)) K ORDIALOG("WP",XCOMM) ;SBR
  1. S ORDOI=+$G(ORDIALOG(4,1))
  1. S ORCATFN="" I $L($P(DLG,U,2)) S ORCATFN=$P(DLG,U,2),DLG=$P(DLG,U,1)
  1. S SENDMSG=0 I $P($G(^ORD(100.98,ORDG,0)),U)="INPATIENT MEDICATIONS" D
  1. .Q:("^PSJ OR PAT OE^PSJI OR PAT FLUID OE^PSJ OR CLINIC OE^CLINIC OR PAT FLUID OE^"'[(U_DLG_U))
  1. .S MSGCAPT("PATIENT")=ORVP,MSGCAPT("USER")=ORNP,MSGCAPT("LOC")=+$G(ORL)
  1. .S MSGCAPT("DIALOG")=DLG,MSGCAPT("DISPLAY GROUP")=ORDG,MSGCAPT("QUICK ORDER")=ORIT
  1. .M MSGCAPT("ORDIALOG")=ORDIALOG
  1. .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")
  1. .S ORDG=$O(^ORD(100.98,"B",NEWORDG,"")),SENDMSG=1
  1. ;Remove treating facility if inpatient and IMO order 26.42
  1. I $G(^DPT(ORVP,.1))'="",$P($G(^ORD(100.98,ORDG,0)),U)="CLINIC MEDICATIONS" K ORDIALOG("ORTS")
  1. I $G(^DPT(ORVP,.1))'="",$P($G(^ORD(100.98,ORDG,0)),U)="CLINIC INFUSIONS" K ORDIALOG("ORTS")
  1. I $G(ORDIALOG("ORTS")) S ORTS=ORDIALOG("ORTS") K ORDIALOG("ORTS")
  1. I $G(ORDIALOG("ORSLOG")) S ORLOG=ORDIALOG("ORSLOG") K ORDIALOG("ORSLOG")
  1. I $D(ORDIALOG("OREVENT")) S OREVENT=ORDIALOG("OREVENT") K ORDIALOG("OREVENT")
  1. I $D(ORDIALOG("OVERRIDE")) S OROVER=ORDIALOG("OVERRIDE") K ORDIALOG("OVERRIDE")
  1. I $D(ORDIALOG("ORREMCOMMENT")) S ORRCOMM=ORDIALOG("ORREMCOMMENT") K ORDIALOG("ORREMCOMMENT")
  1. ;=====================================================
  1. ; Changed for v26.27 (RV)
  1. S ORCAT=$$INPT^ORCD,ORCAT=$S(ORCAT=1:"I",1:"O")
  1. ;I $L($G(OREVENT)) D
  1. ;. S ONPASS=0
  1. ;. S OREVTYPE=$$TYPE^OREVNTX(OREVENT)
  1. ;. I OREVTYPE="T" D ISPASS^OREVNTX1(.ONPASS,+OREVENT,"T")
  1. ;. S ORCAT=$S(OREVTYPE="A":"I",OREVTYPE="T":"I",ONPASS=1:"O",1:"O")
  1. ;E S ORCAT=$S($L($P($G(^DPT(+ORVP,.1)),U)):"I",1:"O")
  1. ;=====================================================
  1. I DLG="PS MEDS" S ORWP94=1 D
  1. . I ORIT=$O(^ORD(101.41,"AB","PSO SUPPLY",0)) S DLG="PSO SUPPLY"
  1. . I ORIT=$O(^ORD(101.41,"AB","PSO OERR",0)) S DLG="PSO OERR"
  1. . I ORIT=$O(^ORD(101.41,"AB","PSJ OR PAT OE",0)) S DLG="PSJ OR PAT OE"
  1. I DLG="PSO OERR"!(DLG="PSO SUPPLY") S ORCAT="O" I $G(OREVENT("EFFECTIVE")) D
  1. . S ORDIALOG($O(^ORD(101.41,"B","OR GTX START DATE"_$S($G(ORWP94):"/TIME",1:""),0)),1)=OREVENT("EFFECTIVE")
  1. I DLG="PSO OERR" D
  1. . N DRUGPRMT,OIPRMT,ORDRUG,OROI
  1. . S DRUGPRMT=+$O(^ORD(101.41,"B","OR GTX DISPENSE DRUG",0))
  1. . S ORDRUG=$G(ORDIALOG(DRUGPRMT,1))
  1. . I ORDRUG,$$ISSUPPLY^ORUTL3(ORDRUG) D
  1. . . S ORDG=+$O(^ORD(100.98,"B","SUPPLIES/DEVICES",0))
  1. . S OIPRMT=+$O(^ORD(101.41,"B","OR GTX ORDERABLE ITEM",0))
  1. . S OROI=$G(ORDIALOG(OIPRMT,1))
  1. . I 'ORDRUG,OROI,$$ISOISPLY^ORUTL3(OROI) D
  1. . . S ORDG=+$O(^ORD(100.98,"B","SUPPLIES/DEVICES",0))
  1. I DLG="PSJ OR PAT OE" S ORCAT="I"
  1. I DLG="PSJ OR CLINIC OE" S ORCAT="I"
  1. I DLG="CLINIC OR PAT FLUID OE" S ORCAT="I"
  1. S:DLG="FHW1" ORCAT="I" S:DLG?1"FHW "2.7U1" MEAL" ORCAT="O"
  1. S ORVP=ORVP_";DPT(",ORL(2)=ORL_";SC(",ORL=ORL(2)
  1. I ORDG=$O(^ORD(100.98,"B","LAB",0)) D ;use section
  1. . N OI,SUB S OI=+$G(ORDIALOG($$PTR^ORCD("OR GTX ORDERABLE ITEM"),1))
  1. . S SUB=$P($G(^ORD(101.43,OI,"LR")),U,6),ORDG=$$DGRP^ORMLR(SUB)
  1. I ORDG=$O(^ORD(100.98,"B","AP",0)) D ;provides orders sort for AP orders by SP, CY and EM
  1. . N OI,SUB S OI=+$G(ORDIALOG($$PTR^ORCD("OR GTX ORDERABLE ITEM"),1))
  1. . S SUB=$P($G(^ORD(101.43,OI,"LR")),U,6),ORDG=$$DGRP^ORMLR(SUB)
  1. K:'ORDG ORDG K:'ORIT ORIT ; Dgrp & Quick must be non-zero
  1. M ORCHECK=ORDIALOG("ORCHECK") K ORDIALOG("ORCHECK")
  1. S ORALLGY=$O(^ORD(100.8,"B","ALLERGY-DRUG INTERACTION",0))
  1. I '$G(DT) S DT=$$DT^XLFDT
  1. S ORALLCHKNM="ORALLERGYCHK"
  1. I '$D(^TMP(ORALLCHKNM,$J,+ORVP,+ORDOI)),$D(^ORD(100.05,"C",+$G(ORIFN),"ACCEPTANCE_CPRS")) D
  1. . N ORAGY,ORCHK,ORDCHK,ORDRGLOC,ORMSG,ORSVR
  1. . I $G(OROVER)="" S OROVER="No override reason given"
  1. . S (NUM,ORAGY)=0
  1. . ;F S ORAGY=$O(^ORD(100.05,"C",+$G(ORIFN),"ACCEPTANCE_CPRS",ORAGY)) Q:ORAGY="" D
  1. . ;. S ORDCHK(1)=$G(^ORD(100.05,ORAGY,1))
  1. . ;. S ORDCHK(4)=$G(^ORD(100.05,ORAGY,4,1,0))
  1. . ;. I ORALLGY'=$P(ORDCHK(1),U,1) Q ;ALLERGY-DRUG INTERACTION only
  1. . ;. S ORSVR=$P(ORDCHK(1),U,2) ;Severity
  1. . ;. S ORMSG=$G(^ORD(100.05,ORAGY,2,1,0))
  1. . ;. S ORCHKCNT=ORCHECK
  1. . ;. N CDL
  1. . ;. S CDL="" F S CDL=$O(ORCHECK("NEW",CDL)) Q:CDL="" D
  1. . ;. . I $O(ORCHECK("NEW",CDL,""),-1)>ORCHKCNT S ORCHKCNT=$O(ORCHECK("NEW",CDL,""),-1)
  1. . ;. S ORCHECK("NEW",1,$I(ORCHKCNT))=ORALLGY_U_ORSVR_U_ORMSG
  1. . ;. S ORCHECK("NEW",1,ORCHKCNT,"OVER")=OROVER
  1. . ;. S ORCHECK=ORCHECK+1
  1. . ;. I $G(ORRCOMM)]"",$P(ORDCHK(4),U,3)="R" D
  1. . ;. . S ORDRGLOC=$P(ORDCHK(4),U,4)_";"_$P(ORDCHK(4),U,1)
  1. . ;. . S ORCHECK("NEW",1,ORCHKCNT,"REMCOMM")=ORRCOMM
  1. . ;. . D SAVRCOM(ORVP,ORDRGLOC,ORRCOMM)
  1. . ;. ;SAVE DATA FOR ORDER CHECK INSTANCES FILE ENTRY (Create as if allergy order checks ran)
  1. . ;. N CLASS,CRC16,ING,ITM,NODE,SIGN
  1. . ;. S CRC16=$$CRC16^XLFCRC(ORMSG)
  1. . ;. S NUM=1+$G(NUM)
  1. . ;. K:NUM=1 ^TMP("OROCIDATA",$J,CRC16)
  1. . ;. S ^TMP("OROCIDATA",$J,CRC16,100.517,NUM,.01)=$P(ORDCHK(4),U,1) ;$P(DATA(J,ITM),U,6)
  1. . ;. 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)
  1. . ;. S ^TMP("OROCIDATA",$J,CRC16,100.517,NUM,6)=$P(ORDCHK(4),U,3) ;$P(DATA(J,ITM),U,2)
  1. . ;. 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)
  1. . ;. S ^TMP("OROCIDATA",$J,CRC16,100.517,NUM,8)=$P(ORDCHK(4),U,5) ;$P(DATA(J,ITM),U,3)
  1. . ;. S ^TMP("OROCIDATA",$J,CRC16,100.517,NUM,9)=$P(ORDCHK(4),U,6) ;$$UP^XLFSTR($P(DATA(J,ITM),U,8))
  1. . ;. S:$P(ORDCHK(4),U,1)'="" ^TMP("OROCIDATA",$J,CRC16,100.517,NUM,10)=$P(ORDCHK(4),U,1) ;SEVERE("MSG")
  1. . ;. S ^TMP("OROCIDATA",$J,CRC16,100.517,NUM,11)=$G(^ORD(100.05,ORAGY,4,1,4)) ;$P(DATA(J,ITM),U,10)
  1. . ;. S (ITM(1),SIGN)=0
  1. . ;. F S SIGN=$O(^ORD(100.05,ORAGY,4,1,3,"B",SIGN)) Q:+SIGN=0 D
  1. . ;. . S ITM(1)=$G(ITM(1))+1
  1. . ;. . S ^TMP("OROCIDATA",$J,CRC16,"SIGN",NUM,"+"_ITM(1)_",")=SIGN
  1. . ;. S ^TMP("OROCIDATA",$J,CRC16,100.05,84)=$P($G(^ORD(100.05,ORAGY,8)),U,4)
  1. . ;. S CLASS=0
  1. . ;. F S CLASS=$O(^ORD(100.05,ORAGY,4,1,1,"B",CLASS)) Q:+CLASS=0 D
  1. . ;. . S ITM(1)=$G(ITM(1))+1
  1. . ;. . S ^TMP("OROCIDATA",$J,CRC16,"CLASS",NUM,"+"_ITM(1)_",")=CLASS
  1. . ;. S ING=0
  1. . ;. F S ING=$O(^ORD(100.05,ORAGY,4,1,2,"B",ING)) Q:+ING=0 D
  1. . ;. . S ITM(1)=$G(ITM(1))+1
  1. . ;. . S ^TMP("OROCIDATA",$J,CRC16,"INGREDIENT",NUM,"+"_ITM(1)_",")=ING
  1. S ORALLXST=0
  1. I $D(^TMP(ORALLCHKNM,$J,+ORVP,+ORDOI)) D
  1. . N ORCHKCNT,ORCHKSVR,ORTMPCHK
  1. . S ORCHKSVR=0
  1. . F S ORCHKSVR=$O(ORCHECK("NEW",ORCHKSVR)) Q:ORCHKSVR="" D Q:ORALLXST
  1. . . S ORCHKCNT=0
  1. . . F S ORCHKCNT=$O(ORCHECK("NEW",ORCHKSVR,ORCHKCNT)) Q:ORCHKCNT="" D Q:ORALLXST
  1. . . . I $P($G(ORCHECK("NEW",ORCHKSVR,ORCHKCNT)),U,1)'=ORALLGY Q
  1. . . . S ORALLXST=1
  1. . I ORALLXST Q
  1. . I $G(OROVER)="" S OROVER="No override reason given"
  1. . S ORCHKCNT=ORCHECK,ORAGYCNT=$O(^TMP(ORALLCHKNM,$J,+ORVP,+ORDOI,""),-1),ORCHECK=ORCHECK+ORAGYCNT
  1. . N CDL
  1. . S CDL="" F S CDL=$O(ORCHECK("NEW",CDL)) Q:CDL="" D
  1. . . I $O(ORCHECK("NEW",CDL,""),-1)>ORCHKCNT S ORCHKCNT=$O(ORCHECK("NEW",CDL,""),-1)
  1. . F ORAGY=1:1:ORAGYCNT D
  1. . . S ORTMPCHK=$G(^TMP(ORALLCHKNM,$J,+ORVP,+ORDOI,ORAGY))
  1. . . S ORCHECK("NEW",1,$I(ORCHKCNT))=$P(ORTMPCHK,U,2,4)
  1. . . S ORCHECK("NEW",1,ORCHKCNT,"OVER")=OROVER
  1. . . I $G(ORRCOMM)]"",$P(ORTMPCHK,U,5)=1 D
  1. . . . S ORCHECK("NEW",1,ORCHKCNT,"REMCOMM")=ORRCOMM
  1. . . . D SAVRCOM(ORVP,$P(ORTMPCHK,U,6),ORRCOMM)
  1. I ORALLXST=1 D
  1. . N ORCHKCNT,ORCHKSVR
  1. . S ORCHKSVR=0
  1. . F S ORCHKSVR=$O(ORCHECK("NEW",ORCHKSVR)) Q:ORCHKSVR="" D
  1. . . S ORCHKCNT=0
  1. . . F S ORCHKCNT=$O(ORCHECK("NEW",ORCHKSVR,ORCHKCNT)) Q:ORCHKCNT="" D
  1. . . . I $P($G(ORCHECK("NEW",ORCHKSVR,ORCHKCNT)),U,1)'=ORALLGY Q
  1. . . . I $G(OROVER)="" S OROVER="No override reason given"
  1. . . . S ORCHECK("NEW",ORCHKSVR,ORCHKCNT,"OVER")=OROVER
  1. . . . S ORTMPCHK=$G(^TMP(ORALLCHKNM,$J,+ORVP,+ORDOI,ORCHKCNT))
  1. . . . I $G(ORRCOMM)]"",$P(ORTMPCHK,U,5)=1 D
  1. . . . . S ORCHECK("NEW",ORCHKSVR,ORCHKCNT,"REMCOMM")=ORRCOMM
  1. . . . . D SAVRCOM(ORVP,$P(ORTMPCHK,U,6),ORRCOMM)
  1. D CLRALLGY^ORWDXC("",+ORVP)
  1. S ORDIALOG=$O(^ORD(101.41,"AB",DLG,0))
  1. I 'ORDIALOG S ORDIALOG=$O(^ORD(101.41,"B",DLG,0))
  1. I $D(ORDIALOG("ORLEAD")) S ORLEAD=ORDIALOG("ORLEAD")
  1. I $D(ORDIALOG("ORTRAIL")) S ORTRAIL=ORDIALOG("ORTRAIL")
  1. D GETDLG1^ORCD(ORDIALOG)
  1. I $L(ORCATFN) S ORCAT=ORCATFN
  1. I $G(ORWP94) D
  1. . N SIGPRMT S SIGPRMT=$O(^ORD(101.41,"B","OR GTX SIG",0))
  1. . N INSPRMT S INSPRMT=$O(^ORD(101.41,"B","OR GTX INSTRUCTIONS",0))
  1. . I $L($G(ORDIALOG(SIGPRMT,1))) S ORDIALOG(INSPRMT,"FORMAT")="@"
  1. . I ORCAT="O" S ORPKG=$O(^DIC(9.4,"C","PSO",0))
  1. . I ORCAT="I" S ORPKG=$O(^DIC(9.4,"C","PSJ",0))
  1. S ORSRC=$G(ORSRC)
  1. D DELPI^ORWDX1 ;delete empty PI
  1. I $G(ORIFN)="" D ; new order
  1. . D EN^ORCSAVE
  1. . S REC="" I ORIFN D GETBYIFN^ORWORR(.REC,ORIFN)
  1. . I '$D(^TMP("ORECALL",$J,ORDIALOG)) M ^TMP("ORECALL",$J,ORDIALOG)=ORDIALOG
  1. E D
  1. . N OR0
  1. . S OR0=$G(^OR(100,+ORIFN,0)),ORSTS=$P($G(^(3)),U,3),ORDG=$P(OR0,U,11)
  1. . I $L($P(OR0,U,17)),ORSTS=10 S OREVENT=$P(OR0,U,17),OREVENT("TS")=$P(OR0,U,13)
  1. . D XX^ORCSAVE ; edit order
  1. . S REC="" S ORIFN=+ORIFN_";"_ORDA D GETBYIFN^ORWORR(.REC,ORIFN)
  1. I SENDMSG D
  1. .S MSGCAPT("ORIGINAL IEN")=$G(ORIFN)
  1. .D MSG^ORUTL5(REC,.MSGCAPT)
  1. D:DLG="GMRCOR CONSULT" CHKAUTO^ORCSLT
  1. D DELORC^ORNORC(ORVP,.ORDIALOG) ; ajb remove order check info from 100.3
  1. Q
  1. ;
  1. ;
  1. SAVRCOM(ORVP,AREC,RCOMM) ;Save Local Comment to Remote Allergy
  1. ;AREC: This will contain the allergy record identifier (RECID)
  1. ; and the original comment presented to the user (PREVCOMM)
  1. N GMR,RECID,PREVCOMM,COMREC,DA,COMMID,LASTCOMM
  1. S RECID=$P(AREC,"~"),PREVCOMM=$P(AREC,"~",2,99)
  1. S DIC="^GMR(120.88,",DIC(0)="F"
  1. S DIE=DIC,LASTCOMM=""
  1. S COMMID=$O(^GMR(120.88,"PR",ORVP,RECID,""),-1)
  1. I COMMID]"" S LASTCOMM=$G(^GMR(120.88,COMMID,1))
  1. Q:LASTCOMM=RCOMM
  1. S DA(.01)=RECID,DA(.02)=ORVP,DA(.03)=$$NOW^XLFDT(),DA(.04)=DUZ,DA(1)=RCOMM
  1. M GMR(120.88,"+1,")=DA
  1. D UPDATE^DIE("","GMR",,"ERROR")
  1. Q