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

ORWDXR.m

Go to the documentation of this file. 
  1. ORWDXR ; SLC/KCM/JDL - Utilites for Order Actions;25-Jun-2013 21:52;PLS
  1.  ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,125,131,134,141,149,187,190,1004,1005,1008,213,243,1010,1011**;Dec 17, 1997;Build 242
  1.  ;
  1.  ; Modified - IHS/MSC/PLS - 09/22/08 - RENEW API mods for REFREQ
  1.  ;                          06/22/11 - Line RNWFLDS+7
  1.  ;                          12/05/12 - Line RENEW+55
  1.  ;                          06/25/13 - Line RENEW+51,RENEW+69
  1. ACTDCREA(DCIEN) ; Valid DC Reason
  1.  N X
  1.  S X=$G(^ORD(100.03,DCIEN,0))
  1.  I $P(X,U,4) Q 0
  1.  I $P(X,U,5)'=+$O(^DIC(9.4,"C","OR",0)) Q 0
  1.  I $P(X,U,7)=+$O(^ORD(100.02,"C","A",0)) Q 0
  1.  Q 1
  1.  ;
  1. ISREL(VAL,ORIFN) ; Return true if an order has been released
  1.  N STS S STS=$P(^OR(100,+ORIFN,3),U,3)
  1.  S VAL=$S(STS=10:0,STS=11:0,1:1)  ; false if delayed or unreleased order
  1.  Q
  1. RENEW(REC,ORIFN,ORVP,ORNP,ORL,FLDS,CPLX,ORAPPT) ; Renew an order
  1.  N ORDG
  1.  N ORDUZ,ORSTS,OREVENT,ORCAT,ORDA,ORTS,ORNEW,ORCHECK,ORLOG,ORPKG
  1.  N ORDIALOG,PRMT,X0
  1.  N FSTDOSE,FST
  1.  S (FSTDOSE,FST)=0
  1.  I '$D(CPLX) S CPLX=0
  1.  I '$G(ORAPPT) S ORAPPT=""
  1.  S ORVP=ORVP_";DPT(",ORL(2)=ORL_";SC(",ORL=ORL(2)
  1.  S X0=^OR(100,+ORIFN,0)
  1.  S ORDG=$P(X0,U,11)
  1.  S ORPKG=$P(X0,U,14)
  1.  I $D(FLDS("ORCHECK")) M ORCHECK=FLDS("ORCHECK")
  1.  I $P(X0,U,5)["101.41," D                        ; version 3
  1.  . S ORDIALOG=+$P(X0,U,5),ORCAT=$P(^OR(100,+ORIFN,0),U,12)
  1.  . D GETDLG^ORCD(ORDIALOG),GETORDER^ORCD(+ORIFN)
  1.  . I CPLX S FSTDOSE=$P($G(ORDIALOG("B","FIRST DOSE")),U,2) S:'FSTDOSE FSTDOSE=$$PTR^ORCD("OR GTX NOW")
  1.  . I FSTDOSE,$G(ORDIALOG(FSTDOSE,1)) K ORDIALOG(FSTDOSE,1)
  1.  E  D                                            ; version 2.5 generic
  1.  . S ORDIALOG=$O(^ORD(101.41,"B","OR GXTEXT WORD PROCESSING ORDE",0))
  1.  . D GETDLG^ORCD(ORDIALOG)
  1.  . S PRMT=$O(^ORD(101.41,"B","OR GTX WORD PROCESSING 1",0))
  1.  . S ORDIALOG(PRMT,1)=$NA(^TMP("ORWORD",$J,PRMT,1))
  1.  . M ^TMP("ORWORD",$J,PRMT,1)=^OR(100,+ORIFN,1)
  1.  . S PRMT=$O(^ORD(101.41,"B","OR GTX START DATE/TIME",0))
  1.  . I $P(X0,U,9) S ORDIALOG(PRMT,1)=$P(X0,U,9)
  1.  I +FLDS(1)=999 D  ; generic order
  1.  . S ORDIALOG($$PTR^ORCD("OR GTX START DATE/TIME"),1)=$P(FLDS(1),U,2)
  1.  . S ORDIALOG($$PTR^ORCD("OR GTX STOP DATE/TIME"),1)=$P(FLDS(1),U,3)
  1.  I ($O(^ORD(101.41,"AB","PS MEDS",0))>0),(+FLDS(1)=130)!(+FLDS(1)=135)!(+FLDS(1)=140),'$L($G(ORDIALOG($$PTR^ORCD("OR GTX SIG"),1))) D
  1.  . N ORDOSE,ORDRUG,ORCAT,ORWPSOI,PROMPT,DRUG
  1.  . S ORCAT=$P($G(^OR(100,+ORIFN,0)),U,12)
  1.  . S PROMPT=$$PTR^ORCD("OR GTX INSTRUCTIONS")
  1.  . S ORDRUG=$G(ORDIALOG($$PTR^ORCD("OR GTX DISPENSE DRUG"),1))
  1.  . S ORWPSOI=+$G(ORDIALOG($$PTR^ORCD("OR GTX ORDERABLE ITEM"),1))
  1.  . I ORWPSOI S ORWPSOI=+$P($G(^ORD(101.43,+ORWPSOI,0)),U,2)
  1.  . D DOSE^PSSORUTL(.ORDOSE,ORWPSOI,$S(ORCAT="I":"U",1:"O"),ORVP)       ; dflt doses
  1.  . D D1^ORCDPS2  ; set up ORDOSE
  1.  . S DRUG=$G(ORDOSE("DD",+ORDRUG))
  1.  . I DRUG,ORCAT="O" D RESETID^ORCDPS
  1.  . D SIG^ORCDPS2
  1.  I +FLDS(1)=140 D  ; outpatient meds
  1.  . K ORDIALOG($$PTR^ORCD("OR GTX START DATE"),1) ; remove effective dt
  1.  . S ORDIALOG($$PTR^ORCD("OR GTX REFILLS"),1)=$P(FLDS(1),U,4)
  1.  . S ORDIALOG($$PTR^ORCD("OR GTX ROUTING"),1)=$P(FLDS(1),U,5)
  1.  . ; IHS/MSC/DKM - 1/21/08 - Begin IHS mods
  1.  . ; IHS/MSC/PLS - 12/03/08 - added e-Prescribing REFREQ support
  1.  . N CMF,SSREFREQ
  1.  . I $G(FLDS("SSREFREQ")) D
  1.  . . S PRMT=$$PTR^ORCD("OR GTX SSREFREQ")
  1.  . . K ^TMP("ORWORD",$J,PRMT)
  1.  . . S I=0 F  S I=$O(FLDS("SSREFREQ",I)) Q:'I  D  ;IHS/MSC/PLS - 06/25/13
  1.  . . .S ^TMP("ORWORD",$J,PRMT,1,I,0)=FLDS("SSREFREQ",I)
  1.  . . .S ^TMP("ORWORD",$J,PRMT,1,0)=U_U_(I)_U_(I)_U_DT_U
  1.  . . S ORDIALOG(PRMT,1)=$NA(^TMP("ORWORD",$J,PRMT,1))
  1.  . E  K ORDIALOG($$PTR^ORCD("OR GTX SSREFREQ"),1)
  1.  . I $G(FLDS("SSRREQIEN")) S ORDIALOG($$PTR^ORCD("OR GTX SSRREQIEN"),1)=+FLDS("SSRREQIEN")
  1.  . E  K ORDIALOG($$PTR^ORCD("OR GTX SSRREQIEN"),1)
  1.  . I $G(FLDS("SSDENYRSN")) S ORDIALOG($$PTR^ORCD("OR GTX SSDENYRSN"),1)=FLDS("SSDENYRSN")
  1.  . E  K ORDIALOG($$PTR^ORCD("OR GTX SSDENYRSN"),1)
  1.  . I $P(FLDS(1),U,6) D
  1.  . . S ORDIALOG($$PTR^ORCD("OR GTX PHARMACY"),1)=$P(FLDS(1),U,6)
  1.  . E  K ORDIALOG($$PTR^ORCD("OR GTX PHARMACY"),1)  ;IHS/MSC/PLS - 12/05/2012
  1.  . I $L($P(FLDS(1),U,7)) S CMF=$P(FLDS(1),U,7)
  1.  . E  S CMF=$$GETCMF1^APSPFNC1(+ORIFN)
  1.  . S ORDIALOG($$PTR^ORCD("OR GTX CMF"),1)=$S(CMF:"Y",1:"N")
  1.  . ; IHS/MSC/DKM - End IHS mods
  1.  . S PRMT=$$PTR^ORCD("OR GTX WORD PROCESSING 1")
  1.  . K ^TMP("ORWORD",$J,PRMT,1)
  1.  . S I=1 F  S I=$O(FLDS(I)) Q:'I  D  ;IHS/MSC/PLS - 06/25/13
  1.  .. S ^TMP("ORWORD",$J,PRMT,1,I-1,0)=FLDS(I)
  1.  .. S ^TMP("ORWORD",$J,PRMT,1,0)=U_U_(I-1)_U_(I-1)_U_DT_U
  1.  . S ORDIALOG(PRMT,1)=$NA(^TMP("ORWORD",$J,PRMT,1))
  1.  . N SIG,PI,X S SIG=$$PTR^ORCD("OR GTX SIG")
  1.  . S PI=$$PTR^ORCD("OR GTX PATIENT INSTRUCTIONS"),X=$$STR(PI)
  1.  . I $L(X),$$STR(SIG)[X S ORDIALOG(PI,"FORMAT")="@" ;PI in Sig
  1.  D RN^ORCSAVE
  1.  S REC="" S ORIFN=+ORIFN_";"_ORDA D GETBYIFN^ORWORR(.REC,ORIFN)
  1.  Q
  1. RNWFLDS(LST,ORIFN) ; Return fields for renew action
  1.  ; LST(0)=RenewType^Start^Stop^Refills^Pickup^Pharmacy^CMF  LST(n)=Comments
  1.  N X0,DG,PKG,RNWTYPE,START,STOP,REFILLS,OROI
  1.  S ORIFN=+ORIFN,X0=^OR(100,ORIFN,0),DG=$P(X0,U,11),PKG=$P(X0,U,14)
  1.  S PKG=$E($P(^DIC(9.4,PKG,0),U,2),1,2),DG=$P(^ORD(100.98,DG,0),U,3)
  1.  S LST(0)=$S(PKG="OR":999,PKG="PS"&(DG="O RX"):140,PKG="PS"&(DG="UD RX"):130,PKG="PS"&(DG="NV RX"):145,1:0)
  1.  I +LST(0)=140 D
  1.  . ;IHS/MSC/PLS - 06/22/2011
  1.  . N PHM
  1.  . S PHM=$$VAL(ORIFN,"PHARMACY")
  1.  . I PHM S PHM=PHM_";"_$$GET1^DIQ(9009033.9,PHM,.01)
  1.  . ;IHS/MSC/DKM - 1/21/08 - Modified next line for e-prescribing and chronic med support
  1.  . ;S LST(0)=LST(0)_U_U_U_+$$VAL(ORIFN,"REFILLS")_U_$$VAL(ORIFN,"PICKUP")
  1.  . ;S LST(0)=LST(0)_U_U_U_+$$VAL(ORIFN,"REFILLS")_U_$$VAL(ORIFN,"PICKUP")_U_$$VAL(ORIFN,"PHARMACY")_U_$$GETCMF1^APSPFNC1(+ORIFN)
  1.  . S LST(0)=LST(0)_U_U_U_+$$VAL(ORIFN,"REFILLS")_U_$$VAL(ORIFN,"PICKUP")_U_PHM_U_$$GETCMF1^APSPFNC1(+ORIFN)
  1.  . ;D WPVAL(.LST,ORIFN,"COMMENT")
  1.  I +LST(0)=999 S LST(0)=LST(0)_U_$$VAL(ORIFN,"START")_U_$$VAL(ORIFN,"STOP")
  1.  ; make sure start/stop times are relative times, otherwise use NOW, no Stop
  1.  I +$P(LST(0),U,2) S $P(LST(0),U,2)="NOW"
  1.  I +$P(LST(0),U,3)!($P(LST(0),U,3)="0") S $P(LST(0),U,3)=""
  1.  ;NEW STUFF AFTER THIS LINE OR*3*243
  1.  S $P(LST(0),U,9)=0
  1.  S OROI=$O(^OR(100,+ORIFN,4.5,"ID","ORDERABLE",0))
  1.  Q:'OROI
  1.  S OROI=$G(^OR(100,+ORIFN,4.5,OROI,1))
  1.  Q:'OROI
  1.  S $P(LST(0),U,9)=$$ISCLOZ^ORALWORD(OROI)
  1.  ; add to LST node specifying if patient of ORIFN passes clozapine lab tests
  1.  I $P(LST(0),U,9) D
  1.  .N ORY,ORDFN,ORTMP
  1.  .S ORTMP=LST(0)
  1.  .K LST
  1.  .S LST(0)=ORTMP
  1.  .S ORDFN=$P(^OR(100,ORIFN,0),U,2)
  1.  .I $P(ORDFN,";",2)'="DPT(" Q
  1.  .S ORDFN=+ORDFN
  1.  .D ALLWORD^ORALWORD(.ORY,ORDFN,ORIFN,"E")
  1.  .M LST(1)=ORY
  1.  Q
  1. VAL(ORIFN,ID) ; Return value for order response
  1.  N DA S DA=+$O(^OR(100,ORIFN,4.5,"ID",ID,0))
  1.  Q $G(^OR(100,ORIFN,4.5,DA,1))
  1. WPVAL(TXT,ORIFN,ID) ; Return word processing value
  1.  N DA S DA=+$O(^OR(100,ORIFN,4.5,"ID",ID,0))
  1.  S I=0 F  S I=$O(^OR(100,ORIFN,4.5,DA,2,I)) Q:'I  S TXT(I)=^(I,0)
  1.  Q
  1. STR(PTR) ; -- Return word processing text as long string for comparison
  1.  N X,Y,I,ARRY
  1.  S ARRY=$G(ORDIALOG(+$G(PTR),1)) Q:'$L(ARRY) ""
  1.  S I=+$O(@ARRY@(0)),Y=$$UP^XLFSTR($G(@ARRY@(I,0)))
  1.  F  S I=+$O(@ARRY@(I)) Q:'I  S X=$G(@ARRY@(I,0)),Y=Y_$$UP^XLFSTR(X)
  1.  S Y=$TR(Y," ") ;remove all spaces, compare only text
  1.  Q Y
  1. CHKACT(ORDERID,ORWSIG,ORWREL,ORWNATR) ; Return error if can't sign/release order
  1.  N ORACT,ORWERR
  1.  ; begin case
  1.  S ORACT=""
  1.  I (ORWSIG=1),$D(^XUSEC("ORES",DUZ)) S ORACT="ES" G XC1
  1.  I (ORWSIG=7),$D(^XUSEC("ORES",DUZ)) S ORACT="DS" G XC1
  1.  I ORWREL,(ORWNATR="W") S ORACT="OC" G XC1
  1.  I ORWREL S ORACT="RS" S:$P($G(^OR(100,+ORDERID,0)),U,16)<2 ORACT="ES"
  1. XC1 ; end case
  1.  S ORWERR=""
  1.  I $L(ORACT),$$VALID^ORCACT0(ORDERID,ORACT,.ORWERR,ORWNATR) S ORWERR=""
  1.  Q ORWERR
  1. GTORITM(Y,ORIFN) ;-- Get back the orderable item IEN
  1.  S ORIFN=+ORIFN
  1.  S Y=$$VALUE^ORCSAVE2(ORIFN,"ORDERABLE")
  1.  Q
  1. GETPKG(Y,IFN) ;Get package for an order
  1.  N ORDERID,PKGID
  1.  Q:+IFN<1
  1.  S ORDERID=+IFN,Y=""
  1.  S PKGID=$P(^OR(100,ORDERID,0),U,14)
  1.  S:PKGID>0 Y=$P(^DIC(9.4,PKGID,0),U,2)
  1.  Q
  1. ISCPLX(ORY,ORID) ; 1: is complex order 0: is not
  1.  Q:'$D(^OR(100,+ORID,0))
  1.  N PKG
  1.  S PKG=$P($G(^OR(100,+ORID,0)),U,14)
  1.  S PKG=$$NMSP^ORCD(PKG)
  1.  I PKG'="PS" Q
  1.  N NUMCHDS,NOWID,NOWVAL
  1.  S (NOWVAL,NOWID)=0
  1.  S NUMCHDS=$P($G(^OR(100,+ORID,2,0)),U,4)
  1.  I NUMCHDS>2 S ORY=1 Q
  1.  I NUMCHDS=2 D
  1.  . S ORY=1
  1.  . S:$D(^OR(100,+ORID,4.5,"ID","NOW")) NOWID=$O(^("NOW",0))
  1.  . S:NOWID NOWVAL=$G(^OR(100,+ORID,4.5,NOWID,1))
  1.  I NOWVAL=1 S ORY=0 Q
  1.  Q
  1. ORCPLX(ORY,ORID,ORACT) ;Return children orders of the complex order
  1.  Q:'$D(^OR(100,+ORID,0))
  1.  N PKG,LACT,OELACT,ISNOW
  1.  S PKG=$P($G(^OR(100,+ORID,0)),U,14)
  1.  S PKG=$$NMSP^ORCD(PKG)
  1.  I PKG'="PS" Q
  1.  N CHLDCNT,IDX,X3
  1.  S (CHLDCNT,IDX)=0
  1.  S:$L($G(^OR(100,+ORID,2,0))) CHLDCNT=$P(^(0),U,4)
  1.  I 'CHLDCNT Q
  1.  F  S IDX=$O(^OR(100,+ORID,2,IDX)) Q:'IDX  D
  1.  . S (LACT,OELACT,ISNOW)=0
  1.  . D ISNOW(.ISNOW,IDX)
  1.  . Q:ISNOW
  1.  . S X3=$G(^OR(100,IDX,3))
  1.  . S LACT=$P(X3,U,7)
  1.  . F  S OELACT=$O(^OR(100,IDX,8,OELACT),-1) Q:OELACT
  1.  . S:OELACT>LACT LACT=OELACT
  1.  . S ORY(IDX)=IDX_";"_LACT
  1.  Q
  1. CANRN(ORY,ORID) ; Check conjunction for renew.
  1.  ; All conjunctioni = "And" return 1
  1.  ; Has a "Then" return 0
  1.  Q:'$G(^OR(100,+ORID,0))
  1.  N PKG
  1.  S PKG=$P($G(^OR(100,+ORID,0)),U,14)
  1.  S PKG=$$NMSP^ORCD(PKG)
  1.  I PKG'="PS" Q
  1.  N INDX,INDY,CANRENEW
  1.  S INDX=0
  1.  S CANRENEW=1
  1.  N CHID
  1.  S CHID=0 F  S CHID=$O(^OR(100,+ORID,2,CHID)) Q:'CHID  D
  1.  . N ORSTS,ACTIVE S ORSTS=0
  1.  . S ORSTS=$P($G(^OR(100,CHID,3)),U,3)
  1.  . S ACTIVE=$O(^ORD(100.01,"B","ACTIVE",0))
  1.  . I ACTIVE'=ORSTS S CANRENEW=0
  1.  I 'CANRENEW S ORY=CANRENEW Q
  1.  F  S INDX=$O(^OR(100,+ORID,4.5,"ID","CONJ",INDX)) Q:'INDX  D
  1.  . S INDY=0 F  S INDY=$O(^OR(100,+ORID,4.5,INDX,INDY)) Q:'INDY  D
  1.  . . I $G(^(INDY))="T" S CANRENEW=0 Q
  1.  . I CANRENEW=0 Q
  1.  S ORY=CANRENEW
  1.  Q
  1. ISNOW(ORY,ORID) ; Is first time now order?
  1.  N SCH
  1.  Q:'$D(^OR(100,+ORID,0))
  1.  S SCH=""
  1.  S SCH=$O(^OR(100,+ORID,4.5,"ID","SCHEDULE",0))
  1.  S:SCH SCH=$G(^OR(100,+ORID,4.5,SCH,1))
  1.  S:SCH="NOW" ORY=1
  1.  Q