ORWDXR ;SLC/KCM/JDL - Utilites for Order Actions ;Sep 01, 2021@10:05:23
;;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
;
ACTDCREA(DCIEN) ; Valid DC Reason
N X
S X=$G(^ORD(100.03,DCIEN,0))
I $P(X,U,4) Q 0
I $P(X,U,5)'=+$O(^DIC(9.4,"C","OR",0)) Q 0
I $P(X,U,7)=+$O(^ORD(100.02,"C","A",0)) Q 0
Q 1
;
ISREL(VAL,ORIFN) ; Return true if an order has been released
N STS S STS=$P(^OR(100,+ORIFN,3),U,3)
S VAL=$S(STS=10:0,STS=11:0,1:1) ; false if delayed or unreleased order
Q
RENEW(REC,ORIFN,ORVP,ORNP,ORL,FLDS,CPLX,ORAPPT) ; Renew an order
N ORDG
N ORDUZ,ORSTS,OREVENT,ORCAT,ORDA,ORTS,ORNEW,ORCHECK,ORLOG,ORPKG
N ORDIALOG,PRMT,X0
N FSTDOSE,FST
;*349 Allow for ORDUZ to come in through FLDS. Allow renewer to be specified by the caller.
S ORDUZ=$G(FLDS("ORDUZ"))
S (FSTDOSE,FST)=0
I '$D(CPLX) S CPLX=0
I '$G(ORAPPT) S ORAPPT=""
S ORVP=ORVP_";DPT(",ORL(2)=ORL_";SC(",ORL=ORL(2)
S X0=^OR(100,+ORIFN,0)
S ORDG=$P(X0,U,11)
S ORTS=$P(X0,U,13) ; 409 - Transfer Treating Specialty
S ORPKG=$P(X0,U,14)
I $D(FLDS("ORCHECK")) M ORCHECK=FLDS("ORCHECK")
I $P(X0,U,5)["101.41," D ; version 3
. S ORDIALOG=+$P(X0,U,5),ORCAT=$P(^OR(100,+ORIFN,0),U,12)
. D GETDLG^ORCD(ORDIALOG),GETORDER^ORCD(+ORIFN)
. ; for titration renewals only copy maintenance portion
. I $$ISTITR^ORUTL3(+ORIFN) D EDTDLG^ORWTITR(.ORDIALOG,+ORIFN)
. I CPLX S FSTDOSE=$P($G(ORDIALOG("B","FIRST DOSE")),U,2) S:'FSTDOSE FSTDOSE=$$PTR^ORCD("OR GTX NOW")
. I FSTDOSE,$G(ORDIALOG(FSTDOSE,1)) K ORDIALOG(FSTDOSE,1)
E D ; version 2.5 generic
. S ORDIALOG=$O(^ORD(101.41,"B","OR GXTEXT WORD PROCESSING ORDE",0))
. D GETDLG^ORCD(ORDIALOG)
. S PRMT=$O(^ORD(101.41,"B","OR GTX WORD PROCESSING 1",0))
. S ORDIALOG(PRMT,1)=$NA(^TMP("ORWORD",$J,PRMT,1))
. M ^TMP("ORWORD",$J,PRMT,1)=^OR(100,+ORIFN,1)
. S PRMT=$O(^ORD(101.41,"B","OR GTX START DATE/TIME",0))
. I $P(X0,U,9) S ORDIALOG(PRMT,1)=$P(X0,U,9)
I +FLDS(1)=999 D ; generic order
. S ORDIALOG($$PTR^ORCD("OR GTX START DATE/TIME"),1)=$P(FLDS(1),U,2)
. S ORDIALOG($$PTR^ORCD("OR GTX STOP DATE/TIME"),1)=$P(FLDS(1),U,3)
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
. N ORDOSE,ORDRUG,ORCAT,ORWPSOI,PROMPT,DRUG
. S ORCAT=$P($G(^OR(100,+ORIFN,0)),U,12)
. S PROMPT=$$PTR^ORCD("OR GTX INSTRUCTIONS")
. S ORDRUG=$G(ORDIALOG($$PTR^ORCD("OR GTX DISPENSE DRUG"),1))
. S ORWPSOI=+$G(ORDIALOG($$PTR^ORCD("OR GTX ORDERABLE ITEM"),1))
. I ORWPSOI S ORWPSOI=+$P($G(^ORD(101.43,+ORWPSOI,0)),U,2)
. D DOSE^PSSORUTL(.ORDOSE,ORWPSOI,$S(ORCAT="I":"U",1:"O"),ORVP) ; dflt doses
. D D1^ORCDPS2 ; set up ORDOSE
. S DRUG=$G(ORDOSE("DD",+ORDRUG))
. I DRUG,ORCAT="O" D RESETID^ORCDPS
. D SIG^ORCDPS2
I +FLDS(1)=140 D ; outpatient meds
. K ORDIALOG($$PTR^ORCD("OR GTX START DATE"),1) ; remove effective dt
. S ORDIALOG($$PTR^ORCD("OR GTX REFILLS"),1)=$P(FLDS(1),U,4)
. S ORDIALOG($$PTR^ORCD("OR GTX ROUTING"),1)=$P(FLDS(1),U,5)
. S ORDIALOG($$PTR^ORCD("OR GTX DAYS SUPPLY"),1)=$P(FLDS(1),U,6)
. S ORDIALOG($$PTR^ORCD("OR GTX QUANTITY"),1)=$P(FLDS(1),U,7)
. S PRMT=$$PTR^ORCD("OR GTX WORD PROCESSING 1")
. K ^TMP("ORWORD",$J,PRMT,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)
. S ^TMP("ORWORD",$J,PRMT,1,0)=U_U_(I-1)_U_(I-1)_U_DT_U
. S ORDIALOG(PRMT,1)=$NA(^TMP("ORWORD",$J,PRMT,1))
. N SIG,PI,X S SIG=$$PTR^ORCD("OR GTX SIG")
. S PI=$$PTR^ORCD("OR GTX PATIENT INSTRUCTIONS"),X=$$STR(PI)
. I $L(X),$$STR(SIG)[X S ORDIALOG(PI,"FORMAT")="@" ;PI in Sig
D RN^ORCSAVE
S REC="" S ORIFN=+ORIFN_";"_ORDA D GETBYIFN^ORWORR(.REC,ORIFN)
Q
RNWFLDS(LST,ORIFN) ; Return fields for renew action
; LST(0)=RenewType^Start^Stop^Refills^Pickup^Days Supply^Quantity^DispUnits^Clozapine
; LST(n)=Comments
N X0,DG,PKG,RNWTYPE,START,STOP,REFILLS,OROI,LOC
N ORI,ORJ,ORMSG,ORORDTXT,ORQTY,ORTITR,Y
S LOC=$P(ORIFN,";",3)
S ORIFN=+ORIFN,X0=^OR(100,ORIFN,0),DG=$P(X0,U,11),PKG=$P(X0,U,14)
S PKG=$E($P(^DIC(9.4,PKG,0),U,2),1,2),DG=$P(^ORD(100.98,DG,0),U,3)
S ORTITR=$$ISTITR^ORUTL3(+ORIFN)
S OROI=$$VAL(ORIFN,"ORDERABLE")
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)
I +LST(0)=140 D
. N ORPICK,ORPREV
. S ORPICK=$$DEFPICK^ORWDPS1("")
. I ORPICK="" D
.. N D3
.. S D3=$G(^OR(100,ORIFN,3))
.. I $P(D3,"^",3)=11,$P(D3,"^",11)=2 S ORPREV=$P(D3,"^",5) I ORPREV]"" S ORPICK=$$VAL(ORPREV,"PICKUP")
.. I $P(D3,"^",3)'=11 S ORPICK=$$VAL(ORIFN,"PICKUP")
.. I ORPICK="" S ORPICK="M^by Mail"
.;COMMENTED OUT THE LINE OF V32 CODE IN FAVOUR OF THE PAPI CODE 5 LINES DOWN
. ;S LST(0)=LST(0)_U_U_U_+$$VAL(ORIFN,"REFILLS")_U_ORPICK
. N XXX ;ADDED THE NEXT FOUR LINES OF PAPI CODE
. S XXX=$$GET^XPAR("LOC.`"_$G(LOC)_"^SYS","ORWDPS ROUTING DEFAULT",1,"I")
. I XXX="N" S XXX=""
. 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")
. ;
. ;for titration renewals, get new Qty and Order Text
. I ORTITR D
. . S ORQTY=$$RNWFLDS^ORWTITR(.ORORDTXT,.ORMSG,$P(ORIFN,";",1,2))
. . S $P(LST(0),U,7)=ORQTY
. ;D WPVAL(.LST,ORIFN,"COMMENT")
I +LST(0)=999 S LST(0)=LST(0)_U_$$VAL(ORIFN,"START")_U_$$VAL(ORIFN,"STOP")
; make sure start/stop times are relative times, otherwise use NOW, no Stop
;I +$P(LST(0),U,2) S $P(LST(0),U,2)="NOW" ;DJE-VM *331 - moved to $$VAL
;I +$P(LST(0),U,3)!($P(LST(0),U,3)="0") S $P(LST(0),U,3)=""
;NEW STUFF AFTER THIS LINE OR*3*243
;
;Indication for use
S Y="" I $D(^OR(100,ORIFN,10)) S Y=$P(^OR(100,ORIFN,10),U,2)
S $P(LST(0),U,10)=Y
;
S $P(LST(0),U,9)=0
I OROI S $P(LST(0),U,9)=$$ISCLOZ^ORALWORD(OROI)
; add to LST node specifying if patient of ORIFN passes clozapine lab tests
I $P(LST(0),U,9) D
.N ORY,ORDFN,ORTMP
.S ORTMP=LST(0)
.K LST
.S LST(0)=ORTMP
.S ORDFN=$P(^OR(100,ORIFN,0),U,2)
.I $P(ORDFN,";",2)'="DPT(" Q
.S ORDFN=+ORDFN
.D ALLWORD^ORALWORD(.ORY,ORDFN,ORIFN,"E")
.M LST(1)=ORY
;
I '$D(ORORDTXT) D
. D TEXT^ORQ12(.ORORDTXT,ORIFN,255)
I $O(^OR(100,+ORIFN,2,0)) D
. S ORI=$O(ORORDTXT(0))
. S ORORDTXT(ORI)="+"_ORORDTXT(ORI)
I $O(^OR(100,+ORIFN,8,"C","XX",0)) D
. S ORI=$O(ORORDTXT(0))
. S ORORDTXT(ORI)="*"_ORORDTXT(ORI)
;
S ORJ=$O(LST(""),-1)
S ORI=0
F S ORI=$O(ORORDTXT(ORI)) Q:'ORI D
. S ORJ=ORJ+1
. S LST(ORJ)="~t"_ORORDTXT(ORI)
;
S ORI=0
F S ORI=$O(ORMSG(ORI)) Q:'ORI D
. S ORJ=ORJ+1
. S LST(ORJ)="~T"_ORMSG(ORI)
;
Q
DISPUNIT(OIEN,ORDISPDRG,ORTYPE) ; Returns the dispense unit
N UNIT,POIREC,PSIEN,DATA
S UNIT=""
I +OIEN'>0 Q UNIT
I ORTYPE="" Q UNIT
S POIREC=$P($G(^ORD(101.43,+OIEN,0)),U,2)
I $P(POIREC,";",2)'="99PSP" Q UNIT
S PSIEN=+POIREC
I PSIEN'>0 Q UNIT
D DOSE^PSSOPKI1(.DATA,PSIEN,ORTYPE)
;I 'ORDISPDRG!('$D(DATA("DD",+ORDISPDRG))) D
;. S ORDISPDRG=$O(DATA("DD",0))
I 'ORDISPDRG Q UNIT
S UNIT=$P($G(DATA("DD",ORDISPDRG)),U,4)
Q UNIT
VAL(ORIFN,ID) ; Return value for order response
N DA,Y,ORDIALOG,ORDGDA,CAPS,XCODE
S DA=+$O(^OR(100,ORIFN,4.5,"ID",ID,0))
I (ID="START")!(ID="STOP") D I 1 ;DJE-VM *331
. ; make sure start/stop times are relative times, otherwise use dialog default values
. S CAPS=$$UP^XLFSTR($G(^OR(100,ORIFN,4.5,DA,1)))
. I ('$L(CAPS))!($E(CAPS)="T")!($E(CAPS)="V")!($E(CAPS)="N"&($E(CAPS,1,3)'="NOV")) S Y=CAPS Q
. S ORDIALOG=$P(^OR(100,+ORIFN,0),U,5)
. S ORDGDA=+^OR(100,ORIFN,4.5,DA,0)
. S XCODE=$G(^ORD(101.41,+ORDIALOG,10,ORDGDA,7))
. I $L(XCODE) X XCODE
. I '$L($G(Y)),ID="START" S Y="NOW" ;if no default, set START to NOW
E S Y=$G(^OR(100,ORIFN,4.5,DA,1))
Q $G(Y)
WPVAL(TXT,ORIFN,ID) ; Return word processing value
N DA,I
S DA=+$O(^OR(100,ORIFN,4.5,"ID",ID,0))
S I=0 F S I=$O(^OR(100,ORIFN,4.5,DA,2,I)) Q:'I S TXT(I)=^(I,0)
Q
STR(PTR) ; -- Return word processing text as long string for comparison
N X,Y,I,ARRY
S ARRY=$G(ORDIALOG(+$G(PTR),1)) Q:'$L(ARRY) ""
S I=+$O(@ARRY@(0)),Y=$$UP^XLFSTR($G(@ARRY@(I,0)))
F S I=+$O(@ARRY@(I)) Q:'I S X=$G(@ARRY@(I,0)),Y=Y_$$UP^XLFSTR(X)
S Y=$TR(Y," ") ;remove all spaces, compare only text
Q Y
CHKACT(ORDERID,ORWSIG,ORWREL,ORWNATR) ; Return error if can't sign/release order
N ORACT,ORWERR
; begin case
S ORACT=""
I (ORWSIG=1),$D(^XUSEC("ORES",DUZ)) S ORACT="ES" G XC1
I (ORWSIG=7),$D(^XUSEC("ORES",DUZ)) S ORACT="DS" G XC1
I ORWREL,(ORWNATR="W") S ORACT="OC" G XC1
I ORWREL S ORACT="RS" S:$P($G(^OR(100,+ORDERID,0)),U,16)<2 ORACT="ES"
XC1 ; end case
S ORWERR=""
I $L(ORACT),$$VALID^ORCACT0(ORDERID,ORACT,.ORWERR,ORWNATR) S ORWERR=""
Q ORWERR
GTORITM(Y,ORIFN) ;-- Get back the orderable item IEN
S ORIFN=+ORIFN
S Y=$$VALUE^ORCSAVE2(ORIFN,"ORDERABLE")
Q
GETPKG(Y,IFN) ;Get package for an order
N ORDERID,PKGID
Q:+IFN<1
S ORDERID=+IFN,Y=""
S PKGID=$P(^OR(100,ORDERID,0),U,14)
S:PKGID>0 Y=$P(^DIC(9.4,PKGID,0),U,2)
Q
ISCPLX(ORY,ORID) ; 1: is complex order 0: is not
Q:'$D(^OR(100,+ORID,0))
N PKG
S PKG=$P($G(^OR(100,+ORID,0)),U,14)
S PKG=$$NMSP^ORCD(PKG)
I PKG'="PS" Q
N NUMCHDS,NOWID,NOWVAL
S (NOWVAL,NOWID)=0
S NUMCHDS=$P($G(^OR(100,+ORID,2,0)),U,4)
I NUMCHDS>2 S ORY=1 Q
I NUMCHDS=2 D
. S ORY=1
. S:$D(^OR(100,+ORID,4.5,"ID","NOW")) NOWID=$O(^("NOW",0))
. S:NOWID NOWVAL=$G(^OR(100,+ORID,4.5,NOWID,1))
I NOWVAL=1 S ORY=0 Q
Q
ORCPLX(ORY,ORID,ORACT) ;Return children orders of the complex order
Q:'$D(^OR(100,+ORID,0))
N PKG,LACT,OELACT,ISNOW
S PKG=$P($G(^OR(100,+ORID,0)),U,14)
S PKG=$$NMSP^ORCD(PKG)
I PKG'="PS" Q
N CHLDCNT,IDX,X3
S (CHLDCNT,IDX)=0
S:$L($G(^OR(100,+ORID,2,0))) CHLDCNT=$P(^(0),U,4)
I 'CHLDCNT Q
F S IDX=$O(^OR(100,+ORID,2,IDX)) Q:'IDX D
. S (LACT,OELACT,ISNOW)=0
. D ISNOW(.ISNOW,IDX)
. Q:ISNOW
. S X3=$G(^OR(100,IDX,3))
. S LACT=$P(X3,U,7)
. F S OELACT=$O(^OR(100,IDX,8,OELACT),-1) Q:OELACT
. S:OELACT>LACT LACT=OELACT
. S ORY(IDX)=IDX_";"_LACT
Q
CANRN(ORY,ORID) ; Check conjunction for renew.
; All conjunctioni = "And" return 1
; Has a "Then" return 0
Q:'$G(^OR(100,+ORID,0))
N PKG
S PKG=$P($G(^OR(100,+ORID,0)),U,14)
S PKG=$$NMSP^ORCD(PKG)
I PKG'="PS" Q
N INDX,INDY,CANRENEW
S INDX=0
S CANRENEW=1
N CHID
S CHID=0 F S CHID=$O(^OR(100,+ORID,2,CHID)) Q:'CHID D
. N ORSTS,ACTIVE S ORSTS=0
. S ORSTS=$P($G(^OR(100,CHID,3)),U,3)
. S ACTIVE=$O(^ORD(100.01,"B","ACTIVE",0))
. I ACTIVE'=ORSTS S CANRENEW=0
I 'CANRENEW S ORY=CANRENEW Q
F S INDX=$O(^OR(100,+ORID,4.5,"ID","CONJ",INDX)) Q:'INDX D
. S INDY=0 F S INDY=$O(^OR(100,+ORID,4.5,INDX,INDY)) Q:'INDY D
. . I $G(^(INDY))="T" S CANRENEW=0 Q
. I CANRENEW=0 Q
S ORY=CANRENEW
Q
ISNOW(ORY,ORID) ; Is first time now order?
N SCH
Q:'$D(^OR(100,+ORID,0))
S SCH=""
S SCH=$O(^OR(100,+ORID,4.5,"ID","SCHEDULE",0))
S:SCH SCH=$G(^OR(100,+ORID,4.5,SCH,1))
S:SCH="NOW" ORY=1
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORWDXR 11101 printed Dec 13, 2024@02:36:04 Page 2
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
+2 ;
ACTDCREA(DCIEN) ; Valid DC Reason
+1 NEW X
+2 SET X=$GET(^ORD(100.03,DCIEN,0))
+3 IF $PIECE(X,U,4)
QUIT 0
+4 IF $PIECE(X,U,5)'=+$ORDER(^DIC(9.4,"C","OR",0))
QUIT 0
+5 IF $PIECE(X,U,7)=+$ORDER(^ORD(100.02,"C","A",0))
QUIT 0
+6 QUIT 1
+7 ;
ISREL(VAL,ORIFN) ; Return true if an order has been released
+1 NEW STS
SET STS=$PIECE(^OR(100,+ORIFN,3),U,3)
+2 ; false if delayed or unreleased order
SET VAL=$SELECT(STS=10:0,STS=11:0,1:1)
+3 QUIT
RENEW(REC,ORIFN,ORVP,ORNP,ORL,FLDS,CPLX,ORAPPT) ; Renew an order
+1 NEW ORDG
+2 NEW ORDUZ,ORSTS,OREVENT,ORCAT,ORDA,ORTS,ORNEW,ORCHECK,ORLOG,ORPKG
+3 NEW ORDIALOG,PRMT,X0
+4 NEW FSTDOSE,FST
+5 ;*349 Allow for ORDUZ to come in through FLDS. Allow renewer to be specified by the caller.
+6 SET ORDUZ=$GET(FLDS("ORDUZ"))
+7 SET (FSTDOSE,FST)=0
+8 IF '$DATA(CPLX)
SET CPLX=0
+9 IF '$GET(ORAPPT)
SET ORAPPT=""
+10 SET ORVP=ORVP_";DPT("
SET ORL(2)=ORL_";SC("
SET ORL=ORL(2)
+11 SET X0=^OR(100,+ORIFN,0)
+12 SET ORDG=$PIECE(X0,U,11)
+13 ; 409 - Transfer Treating Specialty
SET ORTS=$PIECE(X0,U,13)
+14 SET ORPKG=$PIECE(X0,U,14)
+15 IF $DATA(FLDS("ORCHECK"))
MERGE ORCHECK=FLDS("ORCHECK")
+16 ; version 3
IF $PIECE(X0,U,5)["101.41,"
Begin DoDot:1
+17 SET ORDIALOG=+$PIECE(X0,U,5)
SET ORCAT=$PIECE(^OR(100,+ORIFN,0),U,12)
+18 DO GETDLG^ORCD(ORDIALOG)
DO GETORDER^ORCD(+ORIFN)
+19 ; for titration renewals only copy maintenance portion
+20 IF $$ISTITR^ORUTL3(+ORIFN)
DO EDTDLG^ORWTITR(.ORDIALOG,+ORIFN)
+21 IF CPLX
SET FSTDOSE=$PIECE($GET(ORDIALOG("B","FIRST DOSE")),U,2)
if 'FSTDOSE
SET FSTDOSE=$$PTR^ORCD("OR GTX NOW")
+22 IF FSTDOSE
IF $GET(ORDIALOG(FSTDOSE,1))
KILL ORDIALOG(FSTDOSE,1)
End DoDot:1
+23 ; version 2.5 generic
IF '$TEST
Begin DoDot:1
+24 SET ORDIALOG=$ORDER(^ORD(101.41,"B","OR GXTEXT WORD PROCESSING ORDE",0))
+25 DO GETDLG^ORCD(ORDIALOG)
+26 SET PRMT=$ORDER(^ORD(101.41,"B","OR GTX WORD PROCESSING 1",0))
+27 SET ORDIALOG(PRMT,1)=$NAME(^TMP("ORWORD",$JOB,PRMT,1))
+28 MERGE ^TMP("ORWORD",$JOB,PRMT,1)=^OR(100,+ORIFN,1)
+29 SET PRMT=$ORDER(^ORD(101.41,"B","OR GTX START DATE/TIME",0))
+30 IF $PIECE(X0,U,9)
SET ORDIALOG(PRMT,1)=$PIECE(X0,U,9)
End DoDot:1
+31 ; generic order
IF +FLDS(1)=999
Begin DoDot:1
+32 SET ORDIALOG($$PTR^ORCD("OR GTX START DATE/TIME"),1)=$PIECE(FLDS(1),U,2)
+33 SET ORDIALOG($$PTR^ORCD("OR GTX STOP DATE/TIME"),1)=$PIECE(FLDS(1),U,3)
End DoDot:1
+34 IF ($ORDER(^ORD(101.41,"AB","PS MEDS",0))>0)
IF (+FLDS(1)=130)!(+FLDS(1)=135)!(+FLDS(1)=140)
IF '$LENGTH($GET(ORDIALOG($$PTR^ORCD("OR GTX SIG"),1)))
Begin DoDot:1
+35 NEW ORDOSE,ORDRUG,ORCAT,ORWPSOI,PROMPT,DRUG
+36 SET ORCAT=$PIECE($GET(^OR(100,+ORIFN,0)),U,12)
+37 SET PROMPT=$$PTR^ORCD("OR GTX INSTRUCTIONS")
+38 SET ORDRUG=$GET(ORDIALOG($$PTR^ORCD("OR GTX DISPENSE DRUG"),1))
+39 SET ORWPSOI=+$GET(ORDIALOG($$PTR^ORCD("OR GTX ORDERABLE ITEM"),1))
+40 IF ORWPSOI
SET ORWPSOI=+$PIECE($GET(^ORD(101.43,+ORWPSOI,0)),U,2)
+41 ; dflt doses
DO DOSE^PSSORUTL(.ORDOSE,ORWPSOI,$SELECT(ORCAT="I":"U",1:"O"),ORVP)
+42 ; set up ORDOSE
DO D1^ORCDPS2
+43 SET DRUG=$GET(ORDOSE("DD",+ORDRUG))
+44 IF DRUG
IF ORCAT="O"
DO RESETID^ORCDPS
+45 DO SIG^ORCDPS2
End DoDot:1
+46 ; outpatient meds
IF +FLDS(1)=140
Begin DoDot:1
+47 ; remove effective dt
KILL ORDIALOG($$PTR^ORCD("OR GTX START DATE"),1)
+48 SET ORDIALOG($$PTR^ORCD("OR GTX REFILLS"),1)=$PIECE(FLDS(1),U,4)
+49 SET ORDIALOG($$PTR^ORCD("OR GTX ROUTING"),1)=$PIECE(FLDS(1),U,5)
+50 SET ORDIALOG($$PTR^ORCD("OR GTX DAYS SUPPLY"),1)=$PIECE(FLDS(1),U,6)
+51 SET ORDIALOG($$PTR^ORCD("OR GTX QUANTITY"),1)=$PIECE(FLDS(1),U,7)
+52 SET PRMT=$$PTR^ORCD("OR GTX WORD PROCESSING 1")
+53 KILL ^TMP("ORWORD",$JOB,PRMT,1)
+54 NEW I
SET I=1
FOR
SET I=$ORDER(FLDS(I))
if 'I
QUIT
SET ^TMP("ORWORD",$JOB,PRMT,1,I-1,0)=FLDS(I)
+55 SET ^TMP("ORWORD",$JOB,PRMT,1,0)=U_U_(I-1)_U_(I-1)_U_DT_U
+56 SET ORDIALOG(PRMT,1)=$NAME(^TMP("ORWORD",$JOB,PRMT,1))
+57 NEW SIG,PI,X
SET SIG=$$PTR^ORCD("OR GTX SIG")
+58 SET PI=$$PTR^ORCD("OR GTX PATIENT INSTRUCTIONS")
SET X=$$STR(PI)
+59 ;PI in Sig
IF $LENGTH(X)
IF $$STR(SIG)[X
SET ORDIALOG(PI,"FORMAT")="@"
End DoDot:1
+60 DO RN^ORCSAVE
+61 SET REC=""
SET ORIFN=+ORIFN_";"_ORDA
DO GETBYIFN^ORWORR(.REC,ORIFN)
+62 QUIT
RNWFLDS(LST,ORIFN) ; Return fields for renew action
+1 ; LST(0)=RenewType^Start^Stop^Refills^Pickup^Days Supply^Quantity^DispUnits^Clozapine
+2 ; LST(n)=Comments
+3 NEW X0,DG,PKG,RNWTYPE,START,STOP,REFILLS,OROI,LOC
+4 NEW ORI,ORJ,ORMSG,ORORDTXT,ORQTY,ORTITR,Y
+5 SET LOC=$PIECE(ORIFN,";",3)
+6 SET ORIFN=+ORIFN
SET X0=^OR(100,ORIFN,0)
SET DG=$PIECE(X0,U,11)
SET PKG=$PIECE(X0,U,14)
+7 SET PKG=$EXTRACT($PIECE(^DIC(9.4,PKG,0),U,2),1,2)
SET DG=$PIECE(^ORD(100.98,DG,0),U,3)
+8 SET ORTITR=$$ISTITR^ORUTL3(+ORIFN)
+9 SET OROI=$$VAL(ORIFN,"ORDERABLE")
+10 SET LST(0)=$SELECT(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)
+11 IF +LST(0)=140
Begin DoDot:1
+12 NEW ORPICK,ORPREV
+13 SET ORPICK=$$DEFPICK^ORWDPS1("")
+14 IF ORPICK=""
Begin DoDot:2
+15 NEW D3
+16 SET D3=$GET(^OR(100,ORIFN,3))
+17 IF $PIECE(D3,"^",3)=11
IF $PIECE(D3,"^",11)=2
SET ORPREV=$PIECE(D3,"^",5)
IF ORPREV]""
SET ORPICK=$$VAL(ORPREV,"PICKUP")
+18 IF $PIECE(D3,"^",3)'=11
SET ORPICK=$$VAL(ORIFN,"PICKUP")
+19 IF ORPICK=""
SET ORPICK="M^by Mail"
End DoDot:2
+20 ;COMMENTED OUT THE LINE OF V32 CODE IN FAVOUR OF THE PAPI CODE 5 LINES DOWN
+21 ;S LST(0)=LST(0)_U_U_U_+$$VAL(ORIFN,"REFILLS")_U_ORPICK
+22 ;ADDED THE NEXT FOUR LINES OF PAPI CODE
NEW XXX
+23 SET XXX=$$GET^XPAR("LOC.`"_$GET(LOC)_"^SYS","ORWDPS ROUTING DEFAULT",1,"I")
+24 IF XXX="N"
SET XXX=""
+25 SET LST(0)=LST(0)_U_U_U_+$$VAL(ORIFN,"REFILLS")_U_$SELECT(XXX="":$$VAL(ORIFN,"PICKUP"),1:XXX)_U_$$VAL(ORIFN,"SUPPLY")_U_$$VAL(ORIFN,"QTY")_U_$$DISPUNIT(OROI,$$VAL(ORIFN,"DRUG"),"O")
+26 ;
+27 ;for titration renewals, get new Qty and Order Text
+28 IF ORTITR
Begin DoDot:2
+29 SET ORQTY=$$RNWFLDS^ORWTITR(.ORORDTXT,.ORMSG,$PIECE(ORIFN,";",1,2))
+30 SET $PIECE(LST(0),U,7)=ORQTY
End DoDot:2
+31 ;D WPVAL(.LST,ORIFN,"COMMENT")
End DoDot:1
+32 IF +LST(0)=999
SET LST(0)=LST(0)_U_$$VAL(ORIFN,"START")_U_$$VAL(ORIFN,"STOP")
+33 ; make sure start/stop times are relative times, otherwise use NOW, no Stop
+34 ;I +$P(LST(0),U,2) S $P(LST(0),U,2)="NOW" ;DJE-VM *331 - moved to $$VAL
+35 ;I +$P(LST(0),U,3)!($P(LST(0),U,3)="0") S $P(LST(0),U,3)=""
+36 ;NEW STUFF AFTER THIS LINE OR*3*243
+37 ;
+38 ;Indication for use
+39 SET Y=""
IF $DATA(^OR(100,ORIFN,10))
SET Y=$PIECE(^OR(100,ORIFN,10),U,2)
+40 SET $PIECE(LST(0),U,10)=Y
+41 ;
+42 SET $PIECE(LST(0),U,9)=0
+43 IF OROI
SET $PIECE(LST(0),U,9)=$$ISCLOZ^ORALWORD(OROI)
+44 ; add to LST node specifying if patient of ORIFN passes clozapine lab tests
+45 IF $PIECE(LST(0),U,9)
Begin DoDot:1
+46 NEW ORY,ORDFN,ORTMP
+47 SET ORTMP=LST(0)
+48 KILL LST
+49 SET LST(0)=ORTMP
+50 SET ORDFN=$PIECE(^OR(100,ORIFN,0),U,2)
+51 IF $PIECE(ORDFN,";",2)'="DPT("
QUIT
+52 SET ORDFN=+ORDFN
+53 DO ALLWORD^ORALWORD(.ORY,ORDFN,ORIFN,"E")
+54 MERGE LST(1)=ORY
End DoDot:1
+55 ;
+56 IF '$DATA(ORORDTXT)
Begin DoDot:1
+57 DO TEXT^ORQ12(.ORORDTXT,ORIFN,255)
End DoDot:1
+58 IF $ORDER(^OR(100,+ORIFN,2,0))
Begin DoDot:1
+59 SET ORI=$ORDER(ORORDTXT(0))
+60 SET ORORDTXT(ORI)="+"_ORORDTXT(ORI)
End DoDot:1
+61 IF $ORDER(^OR(100,+ORIFN,8,"C","XX",0))
Begin DoDot:1
+62 SET ORI=$ORDER(ORORDTXT(0))
+63 SET ORORDTXT(ORI)="*"_ORORDTXT(ORI)
End DoDot:1
+64 ;
+65 SET ORJ=$ORDER(LST(""),-1)
+66 SET ORI=0
+67 FOR
SET ORI=$ORDER(ORORDTXT(ORI))
if 'ORI
QUIT
Begin DoDot:1
+68 SET ORJ=ORJ+1
+69 SET LST(ORJ)="~t"_ORORDTXT(ORI)
End DoDot:1
+70 ;
+71 SET ORI=0
+72 FOR
SET ORI=$ORDER(ORMSG(ORI))
if 'ORI
QUIT
Begin DoDot:1
+73 SET ORJ=ORJ+1
+74 SET LST(ORJ)="~T"_ORMSG(ORI)
End DoDot:1
+75 ;
+76 QUIT
DISPUNIT(OIEN,ORDISPDRG,ORTYPE) ; Returns the dispense unit
+1 NEW UNIT,POIREC,PSIEN,DATA
+2 SET UNIT=""
+3 IF +OIEN'>0
QUIT UNIT
+4 IF ORTYPE=""
QUIT UNIT
+5 SET POIREC=$PIECE($GET(^ORD(101.43,+OIEN,0)),U,2)
+6 IF $PIECE(POIREC,";",2)'="99PSP"
QUIT UNIT
+7 SET PSIEN=+POIREC
+8 IF PSIEN'>0
QUIT UNIT
+9 DO DOSE^PSSOPKI1(.DATA,PSIEN,ORTYPE)
+10 ;I 'ORDISPDRG!('$D(DATA("DD",+ORDISPDRG))) D
+11 ;. S ORDISPDRG=$O(DATA("DD",0))
+12 IF 'ORDISPDRG
QUIT UNIT
+13 SET UNIT=$PIECE($GET(DATA("DD",ORDISPDRG)),U,4)
+14 QUIT UNIT
VAL(ORIFN,ID) ; Return value for order response
+1 NEW DA,Y,ORDIALOG,ORDGDA,CAPS,XCODE
+2 SET DA=+$ORDER(^OR(100,ORIFN,4.5,"ID",ID,0))
+3 ;DJE-VM *331
IF (ID="START")!(ID="STOP")
Begin DoDot:1
+4 ; make sure start/stop times are relative times, otherwise use dialog default values
+5 SET CAPS=$$UP^XLFSTR($GET(^OR(100,ORIFN,4.5,DA,1)))
+6 IF ('$LENGTH(CAPS))!($EXTRACT(CAPS)="T")!($EXTRACT(CAPS)="V")!($EXTRACT(CAPS)="N"&($EXTRACT(CAPS,1,3)'="NOV"))
SET Y=CAPS
QUIT
+7 SET ORDIALOG=$PIECE(^OR(100,+ORIFN,0),U,5)
+8 SET ORDGDA=+^OR(100,ORIFN,4.5,DA,0)
+9 SET XCODE=$GET(^ORD(101.41,+ORDIALOG,10,ORDGDA,7))
+10 IF $LENGTH(XCODE)
XECUTE XCODE
+11 ;if no default, set START to NOW
IF '$LENGTH($GET(Y))
IF ID="START"
SET Y="NOW"
End DoDot:1
IF 1
+12 IF '$TEST
SET Y=$GET(^OR(100,ORIFN,4.5,DA,1))
+13 QUIT $GET(Y)
WPVAL(TXT,ORIFN,ID) ; Return word processing value
+1 NEW DA,I
+2 SET DA=+$ORDER(^OR(100,ORIFN,4.5,"ID",ID,0))
+3 SET I=0
FOR
SET I=$ORDER(^OR(100,ORIFN,4.5,DA,2,I))
if 'I
QUIT
SET TXT(I)=^(I,0)
+4 QUIT
STR(PTR) ; -- Return word processing text as long string for comparison
+1 NEW X,Y,I,ARRY
+2 SET ARRY=$GET(ORDIALOG(+$GET(PTR),1))
if '$LENGTH(ARRY)
QUIT ""
+3 SET I=+$ORDER(@ARRY@(0))
SET Y=$$UP^XLFSTR($GET(@ARRY@(I,0)))
+4 FOR
SET I=+$ORDER(@ARRY@(I))
if 'I
QUIT
SET X=$GET(@ARRY@(I,0))
SET Y=Y_$$UP^XLFSTR(X)
+5 ;remove all spaces, compare only text
SET Y=$TRANSLATE(Y," ")
+6 QUIT Y
CHKACT(ORDERID,ORWSIG,ORWREL,ORWNATR) ; Return error if can't sign/release order
+1 NEW ORACT,ORWERR
+2 ; begin case
+3 SET ORACT=""
+4 IF (ORWSIG=1)
IF $DATA(^XUSEC("ORES",DUZ))
SET ORACT="ES"
GOTO XC1
+5 IF (ORWSIG=7)
IF $DATA(^XUSEC("ORES",DUZ))
SET ORACT="DS"
GOTO XC1
+6 IF ORWREL
IF (ORWNATR="W")
SET ORACT="OC"
GOTO XC1
+7 IF ORWREL
SET ORACT="RS"
if $PIECE($GET(^OR(100,+ORDERID,0)),U,16)<2
SET ORACT="ES"
XC1 ; end case
+1 SET ORWERR=""
+2 IF $LENGTH(ORACT)
IF $$VALID^ORCACT0(ORDERID,ORACT,.ORWERR,ORWNATR)
SET ORWERR=""
+3 QUIT ORWERR
GTORITM(Y,ORIFN) ;-- Get back the orderable item IEN
+1 SET ORIFN=+ORIFN
+2 SET Y=$$VALUE^ORCSAVE2(ORIFN,"ORDERABLE")
+3 QUIT
GETPKG(Y,IFN) ;Get package for an order
+1 NEW ORDERID,PKGID
+2 if +IFN<1
QUIT
+3 SET ORDERID=+IFN
SET Y=""
+4 SET PKGID=$PIECE(^OR(100,ORDERID,0),U,14)
+5 if PKGID>0
SET Y=$PIECE(^DIC(9.4,PKGID,0),U,2)
+6 QUIT
ISCPLX(ORY,ORID) ; 1: is complex order 0: is not
+1 if '$DATA(^OR(100,+ORID,0))
QUIT
+2 NEW PKG
+3 SET PKG=$PIECE($GET(^OR(100,+ORID,0)),U,14)
+4 SET PKG=$$NMSP^ORCD(PKG)
+5 IF PKG'="PS"
QUIT
+6 NEW NUMCHDS,NOWID,NOWVAL
+7 SET (NOWVAL,NOWID)=0
+8 SET NUMCHDS=$PIECE($GET(^OR(100,+ORID,2,0)),U,4)
+9 IF NUMCHDS>2
SET ORY=1
QUIT
+10 IF NUMCHDS=2
Begin DoDot:1
+11 SET ORY=1
+12 if $DATA(^OR(100,+ORID,4.5,"ID","NOW"))
SET NOWID=$ORDER(^("NOW",0))
+13 if NOWID
SET NOWVAL=$GET(^OR(100,+ORID,4.5,NOWID,1))
End DoDot:1
+14 IF NOWVAL=1
SET ORY=0
QUIT
+15 QUIT
ORCPLX(ORY,ORID,ORACT) ;Return children orders of the complex order
+1 if '$DATA(^OR(100,+ORID,0))
QUIT
+2 NEW PKG,LACT,OELACT,ISNOW
+3 SET PKG=$PIECE($GET(^OR(100,+ORID,0)),U,14)
+4 SET PKG=$$NMSP^ORCD(PKG)
+5 IF PKG'="PS"
QUIT
+6 NEW CHLDCNT,IDX,X3
+7 SET (CHLDCNT,IDX)=0
+8 if $LENGTH($GET(^OR(100,+ORID,2,0)))
SET CHLDCNT=$PIECE(^(0),U,4)
+9 IF 'CHLDCNT
QUIT
+10 FOR
SET IDX=$ORDER(^OR(100,+ORID,2,IDX))
if 'IDX
QUIT
Begin DoDot:1
+11 SET (LACT,OELACT,ISNOW)=0
+12 DO ISNOW(.ISNOW,IDX)
+13 if ISNOW
QUIT
+14 SET X3=$GET(^OR(100,IDX,3))
+15 SET LACT=$PIECE(X3,U,7)
+16 FOR
SET OELACT=$ORDER(^OR(100,IDX,8,OELACT),-1)
if OELACT
QUIT
+17 if OELACT>LACT
SET LACT=OELACT
+18 SET ORY(IDX)=IDX_";"_LACT
End DoDot:1
+19 QUIT
CANRN(ORY,ORID) ; Check conjunction for renew.
+1 ; All conjunctioni = "And" return 1
+2 ; Has a "Then" return 0
+3 if '$GET(^OR(100,+ORID,0))
QUIT
+4 NEW PKG
+5 SET PKG=$PIECE($GET(^OR(100,+ORID,0)),U,14)
+6 SET PKG=$$NMSP^ORCD(PKG)
+7 IF PKG'="PS"
QUIT
+8 NEW INDX,INDY,CANRENEW
+9 SET INDX=0
+10 SET CANRENEW=1
+11 NEW CHID
+12 SET CHID=0
FOR
SET CHID=$ORDER(^OR(100,+ORID,2,CHID))
if 'CHID
QUIT
Begin DoDot:1
+13 NEW ORSTS,ACTIVE
SET ORSTS=0
+14 SET ORSTS=$PIECE($GET(^OR(100,CHID,3)),U,3)
+15 SET ACTIVE=$ORDER(^ORD(100.01,"B","ACTIVE",0))
+16 IF ACTIVE'=ORSTS
SET CANRENEW=0
End DoDot:1
+17 IF 'CANRENEW
SET ORY=CANRENEW
QUIT
+18 FOR
SET INDX=$ORDER(^OR(100,+ORID,4.5,"ID","CONJ",INDX))
if 'INDX
QUIT
Begin DoDot:1
+19 SET INDY=0
FOR
SET INDY=$ORDER(^OR(100,+ORID,4.5,INDX,INDY))
if 'INDY
QUIT
Begin DoDot:2
+20 IF $GET(^(INDY))="T"
SET CANRENEW=0
QUIT
End DoDot:2
+21 IF CANRENEW=0
QUIT
End DoDot:1
+22 SET ORY=CANRENEW
+23 QUIT
ISNOW(ORY,ORID) ; Is first time now order?
+1 NEW SCH
+2 if '$DATA(^OR(100,+ORID,0))
QUIT
+3 SET SCH=""
+4 SET SCH=$ORDER(^OR(100,+ORID,4.5,"ID","SCHEDULE",0))
+5 if SCH
SET SCH=$GET(^OR(100,+ORID,4.5,SCH,1))
+6 if SCH="NOW"
SET ORY=1
+7 QUIT
