ORWDXR ; SLC/KCM/JDL - Utilites for Order Actions;25-Jun-2013 21:52;PLS
;;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
;
; Modified - IHS/MSC/PLS - 09/22/08 - RENEW API mods for REFREQ
; 06/22/11 - Line RNWFLDS+7
; 12/05/12 - Line RENEW+55
; 06/25/13 - Line RENEW+51,RENEW+69
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
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 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)
. 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)
. ; IHS/MSC/DKM - 1/21/08 - Begin IHS mods
. ; IHS/MSC/PLS - 12/03/08 - added e-Prescribing REFREQ support
. N CMF,SSREFREQ
. I $G(FLDS("SSREFREQ")) D
. . S PRMT=$$PTR^ORCD("OR GTX SSREFREQ")
. . K ^TMP("ORWORD",$J,PRMT)
. . S I=0 F S I=$O(FLDS("SSREFREQ",I)) Q:'I D ;IHS/MSC/PLS - 06/25/13
. . .S ^TMP("ORWORD",$J,PRMT,1,I,0)=FLDS("SSREFREQ",I)
. . .S ^TMP("ORWORD",$J,PRMT,1,0)=U_U_(I)_U_(I)_U_DT_U
. . S ORDIALOG(PRMT,1)=$NA(^TMP("ORWORD",$J,PRMT,1))
. E K ORDIALOG($$PTR^ORCD("OR GTX SSREFREQ"),1)
. I $G(FLDS("SSRREQIEN")) S ORDIALOG($$PTR^ORCD("OR GTX SSRREQIEN"),1)=+FLDS("SSRREQIEN")
. E K ORDIALOG($$PTR^ORCD("OR GTX SSRREQIEN"),1)
. I $G(FLDS("SSDENYRSN")) S ORDIALOG($$PTR^ORCD("OR GTX SSDENYRSN"),1)=FLDS("SSDENYRSN")
. E K ORDIALOG($$PTR^ORCD("OR GTX SSDENYRSN"),1)
. I $P(FLDS(1),U,6) D
. . S ORDIALOG($$PTR^ORCD("OR GTX PHARMACY"),1)=$P(FLDS(1),U,6)
. E K ORDIALOG($$PTR^ORCD("OR GTX PHARMACY"),1) ;IHS/MSC/PLS - 12/05/2012
. I $L($P(FLDS(1),U,7)) S CMF=$P(FLDS(1),U,7)
. E S CMF=$$GETCMF1^APSPFNC1(+ORIFN)
. S ORDIALOG($$PTR^ORCD("OR GTX CMF"),1)=$S(CMF:"Y",1:"N")
. ; IHS/MSC/DKM - End IHS mods
. S PRMT=$$PTR^ORCD("OR GTX WORD PROCESSING 1")
. K ^TMP("ORWORD",$J,PRMT,1)
. S I=1 F S I=$O(FLDS(I)) Q:'I D ;IHS/MSC/PLS - 06/25/13
.. 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^Pharmacy^CMF LST(n)=Comments
N X0,DG,PKG,RNWTYPE,START,STOP,REFILLS,OROI
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 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)
I +LST(0)=140 D
. ;IHS/MSC/PLS - 06/22/2011
. N PHM
. S PHM=$$VAL(ORIFN,"PHARMACY")
. I PHM S PHM=PHM_";"_$$GET1^DIQ(9009033.9,PHM,.01)
. ;IHS/MSC/DKM - 1/21/08 - Modified next line for e-prescribing and chronic med support
. ;S LST(0)=LST(0)_U_U_U_+$$VAL(ORIFN,"REFILLS")_U_$$VAL(ORIFN,"PICKUP")
. ;S LST(0)=LST(0)_U_U_U_+$$VAL(ORIFN,"REFILLS")_U_$$VAL(ORIFN,"PICKUP")_U_$$VAL(ORIFN,"PHARMACY")_U_$$GETCMF1^APSPFNC1(+ORIFN)
. S LST(0)=LST(0)_U_U_U_+$$VAL(ORIFN,"REFILLS")_U_$$VAL(ORIFN,"PICKUP")_U_PHM_U_$$GETCMF1^APSPFNC1(+ORIFN)
. ;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"
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
S $P(LST(0),U,9)=0
S OROI=$O(^OR(100,+ORIFN,4.5,"ID","ORDERABLE",0))
Q:'OROI
S OROI=$G(^OR(100,+ORIFN,4.5,OROI,1))
Q:'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
Q
VAL(ORIFN,ID) ; Return value for order response
N DA S DA=+$O(^OR(100,ORIFN,4.5,"ID",ID,0))
Q $G(^OR(100,ORIFN,4.5,DA,1))
WPVAL(TXT,ORIFN,ID) ; Return word processing value
N DA 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
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
+2 ;
+3 ; Modified - IHS/MSC/PLS - 09/22/08 - RENEW API mods for REFREQ
+4 ; 06/22/11 - Line RNWFLDS+7
+5 ; 12/05/12 - Line RENEW+55
+6 ; 06/25/13 - Line RENEW+51,RENEW+69
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 SET (FSTDOSE,FST)=0
+6 IF '$DATA(CPLX)
SET CPLX=0
+7 IF '$GET(ORAPPT)
SET ORAPPT=""
+8 SET ORVP=ORVP_";DPT("
SET ORL(2)=ORL_";SC("
SET ORL=ORL(2)
+9 SET X0=^OR(100,+ORIFN,0)
+10 SET ORDG=$PIECE(X0,U,11)
+11 SET ORPKG=$PIECE(X0,U,14)
+12 IF $DATA(FLDS("ORCHECK"))
MERGE ORCHECK=FLDS("ORCHECK")
+13 ; version 3
IF $PIECE(X0,U,5)["101.41,"
Begin DoDot:1
+14 SET ORDIALOG=+$PIECE(X0,U,5)
SET ORCAT=$PIECE(^OR(100,+ORIFN,0),U,12)
+15 DO GETDLG^ORCD(ORDIALOG)
DO GETORDER^ORCD(+ORIFN)
+16 IF CPLX
SET FSTDOSE=$PIECE($GET(ORDIALOG("B","FIRST DOSE")),U,2)
IF 'FSTDOSE
SET FSTDOSE=$$PTR^ORCD("OR GTX NOW")
+17 IF FSTDOSE
IF $GET(ORDIALOG(FSTDOSE,1))
KILL ORDIALOG(FSTDOSE,1)
End DoDot:1
+18 ; version 2.5 generic
IF '$TEST
Begin DoDot:1
+19 SET ORDIALOG=$ORDER(^ORD(101.41,"B","OR GXTEXT WORD PROCESSING ORDE",0))
+20 DO GETDLG^ORCD(ORDIALOG)
+21 SET PRMT=$ORDER(^ORD(101.41,"B","OR GTX WORD PROCESSING 1",0))
+22 SET ORDIALOG(PRMT,1)=$NAME(^TMP("ORWORD",$JOB,PRMT,1))
+23 MERGE ^TMP("ORWORD",$JOB,PRMT,1)=^OR(100,+ORIFN,1)
+24 SET PRMT=$ORDER(^ORD(101.41,"B","OR GTX START DATE/TIME",0))
+25 IF $PIECE(X0,U,9)
SET ORDIALOG(PRMT,1)=$PIECE(X0,U,9)
End DoDot:1
+26 ; generic order
IF +FLDS(1)=999
Begin DoDot:1
+27 SET ORDIALOG($$PTR^ORCD("OR GTX START DATE/TIME"),1)=$PIECE(FLDS(1),U,2)
+28 SET ORDIALOG($$PTR^ORCD("OR GTX STOP DATE/TIME"),1)=$PIECE(FLDS(1),U,3)
End DoDot:1
+29 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
+30 NEW ORDOSE,ORDRUG,ORCAT,ORWPSOI,PROMPT,DRUG
+31 SET ORCAT=$PIECE($GET(^OR(100,+ORIFN,0)),U,12)
+32 SET PROMPT=$$PTR^ORCD("OR GTX INSTRUCTIONS")
+33 SET ORDRUG=$GET(ORDIALOG($$PTR^ORCD("OR GTX DISPENSE DRUG"),1))
+34 SET ORWPSOI=+$GET(ORDIALOG($$PTR^ORCD("OR GTX ORDERABLE ITEM"),1))
+35 IF ORWPSOI
SET ORWPSOI=+$PIECE($GET(^ORD(101.43,+ORWPSOI,0)),U,2)
+36 ; dflt doses
DO DOSE^PSSORUTL(.ORDOSE,ORWPSOI,$SELECT(ORCAT="I":"U",1:"O"),ORVP)
+37 ; set up ORDOSE
DO D1^ORCDPS2
+38 SET DRUG=$GET(ORDOSE("DD",+ORDRUG))
+39 IF DRUG
IF ORCAT="O"
DO RESETID^ORCDPS
+40 DO SIG^ORCDPS2
End DoDot:1
+41 ; outpatient meds
IF +FLDS(1)=140
Begin DoDot:1
+42 ; remove effective dt
KILL ORDIALOG($$PTR^ORCD("OR GTX START DATE"),1)
+43 SET ORDIALOG($$PTR^ORCD("OR GTX REFILLS"),1)=$PIECE(FLDS(1),U,4)
+44 SET ORDIALOG($$PTR^ORCD("OR GTX ROUTING"),1)=$PIECE(FLDS(1),U,5)
+45 ; IHS/MSC/DKM - 1/21/08 - Begin IHS mods
+46 ; IHS/MSC/PLS - 12/03/08 - added e-Prescribing REFREQ support
+47 NEW CMF,SSREFREQ
+48 IF $GET(FLDS("SSREFREQ"))
Begin DoDot:2
+49 SET PRMT=$$PTR^ORCD("OR GTX SSREFREQ")
+50 KILL ^TMP("ORWORD",$JOB,PRMT)
+51 ;IHS/MSC/PLS - 06/25/13
SET I=0
FOR
SET I=$ORDER(FLDS("SSREFREQ",I))
IF 'I
QUIT
Begin DoDot:3
+52 SET ^TMP("ORWORD",$JOB,PRMT,1,I,0)=FLDS("SSREFREQ",I)
+53 SET ^TMP("ORWORD",$JOB,PRMT,1,0)=U_U_(I)_U_(I)_U_DT_U
End DoDot:3
+54 SET ORDIALOG(PRMT,1)=$NAME(^TMP("ORWORD",$JOB,PRMT,1))
End DoDot:2
+55 IF '$TEST
KILL ORDIALOG($$PTR^ORCD("OR GTX SSREFREQ"),1)
+56 IF $GET(FLDS("SSRREQIEN"))
SET ORDIALOG($$PTR^ORCD("OR GTX SSRREQIEN"),1)=+FLDS("SSRREQIEN")
+57 IF '$TEST
KILL ORDIALOG($$PTR^ORCD("OR GTX SSRREQIEN"),1)
+58 IF $GET(FLDS("SSDENYRSN"))
SET ORDIALOG($$PTR^ORCD("OR GTX SSDENYRSN"),1)=FLDS("SSDENYRSN")
+59 IF '$TEST
KILL ORDIALOG($$PTR^ORCD("OR GTX SSDENYRSN"),1)
+60 IF $PIECE(FLDS(1),U,6)
Begin DoDot:2
+61 SET ORDIALOG($$PTR^ORCD("OR GTX PHARMACY"),1)=$PIECE(FLDS(1),U,6)
End DoDot:2
+62 ;IHS/MSC/PLS - 12/05/2012
IF '$TEST
KILL ORDIALOG($$PTR^ORCD("OR GTX PHARMACY"),1)
+63 IF $LENGTH($PIECE(FLDS(1),U,7))
SET CMF=$PIECE(FLDS(1),U,7)
+64 IF '$TEST
SET CMF=$$GETCMF1^APSPFNC1(+ORIFN)
+65 SET ORDIALOG($$PTR^ORCD("OR GTX CMF"),1)=$SELECT(CMF:"Y",1:"N")
+66 ; IHS/MSC/DKM - End IHS mods
+67 SET PRMT=$$PTR^ORCD("OR GTX WORD PROCESSING 1")
+68 KILL ^TMP("ORWORD",$JOB,PRMT,1)
+69 ;IHS/MSC/PLS - 06/25/13
SET I=1
FOR
SET I=$ORDER(FLDS(I))
IF 'I
QUIT
Begin DoDot:2
+70 SET ^TMP("ORWORD",$JOB,PRMT,1,I-1,0)=FLDS(I)
+71 SET ^TMP("ORWORD",$JOB,PRMT,1,0)=U_U_(I-1)_U_(I-1)_U_DT_U
End DoDot:2
+72 SET ORDIALOG(PRMT,1)=$NAME(^TMP("ORWORD",$JOB,PRMT,1))
+73 NEW SIG,PI,X
SET SIG=$$PTR^ORCD("OR GTX SIG")
+74 SET PI=$$PTR^ORCD("OR GTX PATIENT INSTRUCTIONS")
SET X=$$STR(PI)
+75 ;PI in Sig
IF $LENGTH(X)
IF $$STR(SIG)[X
SET ORDIALOG(PI,"FORMAT")="@"
End DoDot:1
+76 DO RN^ORCSAVE
+77 SET REC=""
SET ORIFN=+ORIFN_";"_ORDA
DO GETBYIFN^ORWORR(.REC,ORIFN)
+78 QUIT
RNWFLDS(LST,ORIFN) ; Return fields for renew action
+1 ; LST(0)=RenewType^Start^Stop^Refills^Pickup^Pharmacy^CMF LST(n)=Comments
+2 NEW X0,DG,PKG,RNWTYPE,START,STOP,REFILLS,OROI
+3 SET ORIFN=+ORIFN
SET X0=^OR(100,ORIFN,0)
SET DG=$PIECE(X0,U,11)
SET PKG=$PIECE(X0,U,14)
+4 SET PKG=$EXTRACT($PIECE(^DIC(9.4,PKG,0),U,2),1,2)
SET DG=$PIECE(^ORD(100.98,DG,0),U,3)
+5 SET LST(0)=$SELECT(PKG="OR":999,PKG="PS"&(DG="O RX"):140,PKG="PS"&(DG="UD RX"):130,PKG="PS"&(DG="NV RX"):145,1:0)
+6 IF +LST(0)=140
Begin DoDot:1
+7 ;IHS/MSC/PLS - 06/22/2011
+8 NEW PHM
+9 SET PHM=$$VAL(ORIFN,"PHARMACY")
+10 IF PHM
SET PHM=PHM_";"_$$GET1^DIQ(9009033.9,PHM,.01)
+11 ;IHS/MSC/DKM - 1/21/08 - Modified next line for e-prescribing and chronic med support
+12 ;S LST(0)=LST(0)_U_U_U_+$$VAL(ORIFN,"REFILLS")_U_$$VAL(ORIFN,"PICKUP")
+13 ;S LST(0)=LST(0)_U_U_U_+$$VAL(ORIFN,"REFILLS")_U_$$VAL(ORIFN,"PICKUP")_U_$$VAL(ORIFN,"PHARMACY")_U_$$GETCMF1^APSPFNC1(+ORIFN)
+14 SET LST(0)=LST(0)_U_U_U_+$$VAL(ORIFN,"REFILLS")_U_$$VAL(ORIFN,"PICKUP")_U_PHM_U_$$GETCMF1^APSPFNC1(+ORIFN)
+15 ;D WPVAL(.LST,ORIFN,"COMMENT")
End DoDot:1
+16 IF +LST(0)=999
SET LST(0)=LST(0)_U_$$VAL(ORIFN,"START")_U_$$VAL(ORIFN,"STOP")
+17 ; make sure start/stop times are relative times, otherwise use NOW, no Stop
+18 IF +$PIECE(LST(0),U,2)
SET $PIECE(LST(0),U,2)="NOW"
+19 IF +$PIECE(LST(0),U,3)!($PIECE(LST(0),U,3)="0")
SET $PIECE(LST(0),U,3)=""
+20 ;NEW STUFF AFTER THIS LINE OR*3*243
+21 SET $PIECE(LST(0),U,9)=0
+22 SET OROI=$ORDER(^OR(100,+ORIFN,4.5,"ID","ORDERABLE",0))
+23 IF 'OROI
QUIT
+24 SET OROI=$GET(^OR(100,+ORIFN,4.5,OROI,1))
+25 IF 'OROI
QUIT
+26 SET $PIECE(LST(0),U,9)=$$ISCLOZ^ORALWORD(OROI)
+27 ; add to LST node specifying if patient of ORIFN passes clozapine lab tests
+28 IF $PIECE(LST(0),U,9)
Begin DoDot:1
+29 NEW ORY,ORDFN,ORTMP
+30 SET ORTMP=LST(0)
+31 KILL LST
+32 SET LST(0)=ORTMP
+33 SET ORDFN=$PIECE(^OR(100,ORIFN,0),U,2)
+34 IF $PIECE(ORDFN,";",2)'="DPT("
QUIT
+35 SET ORDFN=+ORDFN
+36 DO ALLWORD^ORALWORD(.ORY,ORDFN,ORIFN,"E")
+37 MERGE LST(1)=ORY
End DoDot:1
+38 QUIT
VAL(ORIFN,ID) ; Return value for order response
+1 NEW DA
SET DA=+$ORDER(^OR(100,ORIFN,4.5,"ID",ID,0))
+2 QUIT $GET(^OR(100,ORIFN,4.5,DA,1))
WPVAL(TXT,ORIFN,ID) ; Return word processing value
+1 NEW DA
SET DA=+$ORDER(^OR(100,ORIFN,4.5,"ID",ID,0))
+2 SET I=0
FOR
SET I=$ORDER(^OR(100,ORIFN,4.5,DA,2,I))
IF 'I
QUIT
SET TXT(I)=^(I,0)
+3 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
