- 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 Jan 18, 2025@03:37:13 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