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 ;Sep 01, 2021@10:05:23
  1. ;;3.0;ORDER ENTRY/RESULTS REPORTING;**10,85,125,131,134,141,149,187,190,213,243,331,306,349,374,409,397,405**;Dec 17, 1997;Build 211
  1. ;
  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. ;*349 Allow for ORDUZ to come in through FLDS. Allow renewer to be specified by the caller.
  1. S ORDUZ=$G(FLDS("ORDUZ"))
  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 ORTS=$P(X0,U,13) ; 409 - Transfer Treating Specialty
  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. . ; for titration renewals only copy maintenance portion
  1. . I $$ISTITR^ORUTL3(+ORIFN) D EDTDLG^ORWTITR(.ORDIALOG,+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. . S ORDIALOG($$PTR^ORCD("OR GTX DAYS SUPPLY"),1)=$P(FLDS(1),U,6)
  1. . S ORDIALOG($$PTR^ORCD("OR GTX QUANTITY"),1)=$P(FLDS(1),U,7)
  1. . S PRMT=$$PTR^ORCD("OR GTX WORD PROCESSING 1")
  1. . K ^TMP("ORWORD",$J,PRMT,1)
  1. . N I S I=1 F S I=$O(FLDS(I)) Q:'I 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^Days Supply^Quantity^DispUnits^Clozapine
  1. ; LST(n)=Comments
  1. N X0,DG,PKG,RNWTYPE,START,STOP,REFILLS,OROI,LOC
  1. N ORI,ORJ,ORMSG,ORORDTXT,ORQTY,ORTITR,Y
  1. S LOC=$P(ORIFN,";",3)
  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 ORTITR=$$ISTITR^ORUTL3(+ORIFN)
  1. S OROI=$$VAL(ORIFN,"ORDERABLE")
  1. S LST(0)=$S(PKG="OR":999,PKG="PS"&((DG="O RX")!(DG="SPLY")):140,PKG="PS"&(DG="UD RX"):130,PKG="PS"&(DG="NV RX"):145,1:0)
  1. I +LST(0)=140 D
  1. . N ORPICK,ORPREV
  1. . S ORPICK=$$DEFPICK^ORWDPS1("")
  1. . I ORPICK="" D
  1. .. N D3
  1. .. S D3=$G(^OR(100,ORIFN,3))
  1. .. I $P(D3,"^",3)=11,$P(D3,"^",11)=2 S ORPREV=$P(D3,"^",5) I ORPREV]"" S ORPICK=$$VAL(ORPREV,"PICKUP")
  1. .. I $P(D3,"^",3)'=11 S ORPICK=$$VAL(ORIFN,"PICKUP")
  1. .. I ORPICK="" S ORPICK="M^by Mail"
  1. .;COMMENTED OUT THE LINE OF V32 CODE IN FAVOUR OF THE PAPI CODE 5 LINES DOWN
  1. . ;S LST(0)=LST(0)_U_U_U_+$$VAL(ORIFN,"REFILLS")_U_ORPICK
  1. . N XXX ;ADDED THE NEXT FOUR LINES OF PAPI CODE
  1. . S XXX=$$GET^XPAR("LOC.`"_$G(LOC)_"^SYS","ORWDPS ROUTING DEFAULT",1,"I")
  1. . I XXX="N" S XXX=""
  1. . S LST(0)=LST(0)_U_U_U_+$$VAL(ORIFN,"REFILLS")_U_$S(XXX="":$$VAL(ORIFN,"PICKUP"),1:XXX)_U_$$VAL(ORIFN,"SUPPLY")_U_$$VAL(ORIFN,"QTY")_U_$$DISPUNIT(OROI,$$VAL(ORIFN,"DRUG"),"O")
  1. . ;
  1. . ;for titration renewals, get new Qty and Order Text
  1. . I ORTITR D
  1. . . S ORQTY=$$RNWFLDS^ORWTITR(.ORORDTXT,.ORMSG,$P(ORIFN,";",1,2))
  1. . . S $P(LST(0),U,7)=ORQTY
  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" ;DJE-VM *331 - moved to $$VAL
  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. ;
  1. ;Indication for use
  1. S Y="" I $D(^OR(100,ORIFN,10)) S Y=$P(^OR(100,ORIFN,10),U,2)
  1. S $P(LST(0),U,10)=Y
  1. ;
  1. S $P(LST(0),U,9)=0
  1. I OROI 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. ;
  1. I '$D(ORORDTXT) D
  1. . D TEXT^ORQ12(.ORORDTXT,ORIFN,255)
  1. I $O(^OR(100,+ORIFN,2,0)) D
  1. . S ORI=$O(ORORDTXT(0))
  1. . S ORORDTXT(ORI)="+"_ORORDTXT(ORI)
  1. I $O(^OR(100,+ORIFN,8,"C","XX",0)) D
  1. . S ORI=$O(ORORDTXT(0))
  1. . S ORORDTXT(ORI)="*"_ORORDTXT(ORI)
  1. ;
  1. S ORJ=$O(LST(""),-1)
  1. S ORI=0
  1. F S ORI=$O(ORORDTXT(ORI)) Q:'ORI D
  1. . S ORJ=ORJ+1
  1. . S LST(ORJ)="~t"_ORORDTXT(ORI)
  1. ;
  1. S ORI=0
  1. F S ORI=$O(ORMSG(ORI)) Q:'ORI D
  1. . S ORJ=ORJ+1
  1. . S LST(ORJ)="~T"_ORMSG(ORI)
  1. ;
  1. Q
  1. DISPUNIT(OIEN,ORDISPDRG,ORTYPE) ; Returns the dispense unit
  1. N UNIT,POIREC,PSIEN,DATA
  1. S UNIT=""
  1. I +OIEN'>0 Q UNIT
  1. I ORTYPE="" Q UNIT
  1. S POIREC=$P($G(^ORD(101.43,+OIEN,0)),U,2)
  1. I $P(POIREC,";",2)'="99PSP" Q UNIT
  1. S PSIEN=+POIREC
  1. I PSIEN'>0 Q UNIT
  1. D DOSE^PSSOPKI1(.DATA,PSIEN,ORTYPE)
  1. ;I 'ORDISPDRG!('$D(DATA("DD",+ORDISPDRG))) D
  1. ;. S ORDISPDRG=$O(DATA("DD",0))
  1. I 'ORDISPDRG Q UNIT
  1. S UNIT=$P($G(DATA("DD",ORDISPDRG)),U,4)
  1. Q UNIT
  1. VAL(ORIFN,ID) ; Return value for order response
  1. N DA,Y,ORDIALOG,ORDGDA,CAPS,XCODE
  1. S DA=+$O(^OR(100,ORIFN,4.5,"ID",ID,0))
  1. I (ID="START")!(ID="STOP") D I 1 ;DJE-VM *331
  1. . ; make sure start/stop times are relative times, otherwise use dialog default values
  1. . S CAPS=$$UP^XLFSTR($G(^OR(100,ORIFN,4.5,DA,1)))
  1. . I ('$L(CAPS))!($E(CAPS)="T")!($E(CAPS)="V")!($E(CAPS)="N"&($E(CAPS,1,3)'="NOV")) S Y=CAPS Q
  1. . S ORDIALOG=$P(^OR(100,+ORIFN,0),U,5)
  1. . S ORDGDA=+^OR(100,ORIFN,4.5,DA,0)
  1. . S XCODE=$G(^ORD(101.41,+ORDIALOG,10,ORDGDA,7))
  1. . I $L(XCODE) X XCODE
  1. . I '$L($G(Y)),ID="START" S Y="NOW" ;if no default, set START to NOW
  1. E S Y=$G(^OR(100,ORIFN,4.5,DA,1))
  1. Q $G(Y)
  1. WPVAL(TXT,ORIFN,ID) ; Return word processing value
  1. N DA,I
  1. 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