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

ORWTITR.m

Go to the documentation of this file. 
  1. ORWTITR ;ISP/LMT - Titrating RX Renewals ;Jul 27, 2018@06:49
  1.  ;;3.0;ORDER ENTRY/RESULTS REPORTING;**405**;Dec 17, 1997;Build 211
  1.  ;
  1.  ;
  1.  ; Reference to DOSE^PSSORUTL supported by ICR #3233
  1.  ;
  1.  Q
  1.  ;
  1.  ; *******************************************************
  1.  ; Edits Order Dialog Responses for titration renews.
  1.  ; Only use responses after last "then".
  1. EDTDLG(ORDIALOG,ORIFN) ;
  1.  ;
  1.  N ORCHILD,ORCONJ,ORI,ORINSTR,ORLASTTHEN,ORM,ORSEQ,ORSIG
  1.  ;
  1.  I '$G(ORDIALOG) S ORDIALOG=+$P($G(^OR(100,+ORIFN,0)),U,5)
  1.  ;
  1.  S ORINSTR=$$PTR^ORCD("OR GTX INSTRUCTIONS")
  1.  S ORCONJ=$$PTR^ORCD("OR GTX AND/THEN")
  1.  S ORSIG=$$PTR^ORCD("OR GTX SIG")
  1.  ;
  1.  ; Find last "then" conjunction
  1.  S ORLASTTHEN=0
  1.  S ORI="00"
  1.  F  S ORI=$O(ORDIALOG(ORCONJ,ORI),-1) Q:'ORI!(ORLASTTHEN)  D
  1.  . I ORDIALOG(ORCONJ,ORI)="T" S ORLASTTHEN=ORI
  1.  I 'ORLASTTHEN Q
  1.  ;
  1.  ; Remove all responses for OR GTX INSTRUCTIONS that precede last "then"
  1.  D DELRESP(.ORDIALOG,ORINSTR,ORLASTTHEN)
  1.  ;
  1.  ; Remove all responses for children of OR GTX INSTRUCTIONS that precede last "then"
  1.  S ORSEQ=0
  1.  F  S ORSEQ=$O(^ORD(101.41,ORDIALOG,10,"DAD",ORINSTR,ORSEQ)) Q:ORSEQ=""  D
  1.  . S ORM=0
  1.  . F  S ORM=$O(^ORD(101.41,ORDIALOG,10,"DAD",ORINSTR,ORSEQ,ORM)) Q:'ORM  D
  1.  . . S ORCHILD=$P($G(^ORD(101.41,ORDIALOG,10,ORM,0)),U,2)
  1.  . . D DELRESP(.ORDIALOG,ORCHILD,ORLASTTHEN)
  1.  ;
  1.  ; recalculate QTY
  1.  ; ** TODO - We might need to allow provider to change the QTY we calculate; need to ask Rob**
  1.  D QTY(.ORDIALOG,+ORIFN)
  1.  ;
  1.  ;Remove Titration response
  1.  D REMTITR(.ORDIALOG,+ORIFN)
  1.  ;
  1.  ; recalculate SIG
  1.  K ORDIALOG(ORSIG,1)
  1.  D SIG(.ORDIALOG,+ORIFN)
  1.  ;
  1.  Q
  1.  ;
  1.  ;**********************
  1.  ; deletes all dialog responses <= ORNUM
  1. DELRESP(ORDIALOG,ORPTR,ORNUM) ;
  1.  ;
  1.  N ORCNT,ORI,ORNEW
  1.  ;
  1.  I '$D(ORDIALOG(ORPTR)) Q
  1.  ;
  1.  ; only keep responses > ORNUM
  1.  S ORCNT=0
  1.  S ORI=0
  1.  F  S ORI=$O(ORDIALOG(ORPTR,ORI)) Q:'ORI  D
  1.  . I ORI>ORNUM D
  1.  . . S ORCNT=ORCNT+1
  1.  . . S ORNEW(ORCNT)=ORDIALOG(ORPTR,ORI)
  1.  . K ORDIALOG(ORPTR,ORI)
  1.  M ORDIALOG(ORPTR)=ORNEW
  1.  ;
  1.  ; if there are no more responses left, kill the entire ORDIALOG entry
  1.  I '$O(ORDIALOG(ORPTR,0)) D  Q
  1.  . S ORI=$$UP^XLFSTR($P($G(ORDIALOG(ORPTR,"A")),":",1))
  1.  . I ORI'="" K ORDIALOG("B",ORI)
  1.  . K ORDIALOG(ORPTR)
  1.  ;
  1.  Q
  1.  ;
  1.  ;************************************
  1.  ; Recalculates SIG
  1. SIG(ORDIALOG,ORIFN) ;
  1.  ;
  1.  N ORDOSE,ORDRUG,ORCAT,ORVP,ORWPSOI,PROMPT,DRUG
  1.  ;
  1.  S ORVP=$P($G(^OR(100,+ORIFN,0)),U,2)
  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)  ; ICR #3233
  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.  ;
  1.  Q
  1.  ;
  1.  ;************************************
  1.  ; Recalculates QTY
  1. QTY(ORDIALOG,ORIFN) ;
  1.  ;
  1.  N ORDRUG,ORDSUP,ORQTY,ORVP
  1.  ;
  1.  S ORVP=$P($G(^OR(100,+ORIFN,0)),U,2)
  1.  S ORDRUG=$G(ORDIALOG($$PTR^ORCD("OR GTX DISPENSE DRUG"),1))
  1.  S ORDSUP=$G(ORDIALOG($$PTR^ORCD("OR GTX DAYS SUPPLY"),1))
  1.  ;
  1.  S ORQTY=+$$QTY^ORCDPS1
  1.  ;I ORQTY>0 S ORDIALOG($$PTR^ORCD("OR GTX QUANTITY"),1)=ORQTY
  1.  S ORDIALOG($$PTR^ORCD("OR GTX QUANTITY"),1)=ORQTY
  1.  ;
  1.  Q
  1.  ;
  1.  ;************************************
  1.  ; remove Titration response
  1. REMTITR(ORDIALOG,ORIFN) ;
  1.  ;
  1.  N ORTITR
  1.  ;
  1.  S ORTITR=$$PTR^ORCD("OR GTX TITRATION")
  1.  D DELRESP(.ORDIALOG,ORTITR,1)
  1.  ;
  1.  Q
  1.  ;
  1.  ; *************************************
  1.  ; return Order Text based off updated ORDIALOG
  1. ORDTXT(ORTXT,ORIFN,ORDIALOG) ;
  1.  ;
  1.  N ORTX
  1.  ;
  1.  D ORTX^ORCSAVE1(240)
  1.  M ORTXT=ORTX
  1.  ;
  1.  Q
  1.  ;
  1.  ; *******************************************
  1.  ; For renewals, Return new Order Text for titration order
  1.  ; and new Qty
  1. RNWFLDS(ORTX,ORMSG,ORIFN) ;
  1.  ;
  1.  N ORDIALOG,ORFIRST,ORI,ORNEWQTY,OROLDQTY,ORTMP,WIDTH,X
  1.  ;
  1.  S ORDIALOG=$P($G(^OR(100,ORIFN,0)),U,5)
  1.  I ORDIALOG'["101.41," Q ""
  1.  S ORDIALOG=+ORDIALOG
  1.  D GETDLG^ORCD(ORDIALOG)
  1.  D GETORDER^ORCD(+ORIFN)
  1.  S OROLDQTY=$G(ORDIALOG($$PTR^ORCD("OR GTX QUANTITY"),1))
  1.  D EDTDLG(.ORDIALOG,ORIFN)
  1.  S ORNEWQTY=$G(ORDIALOG($$PTR^ORCD("OR GTX QUANTITY"),1))
  1.  ;
  1.  ; Return Order Text
  1.  D ORDTXT(.ORTMP,ORIFN,.ORDIALOG)
  1.  S WIDTH=255
  1.  S ORTX=1
  1.  S ORTX(ORTX)=""
  1.  S ORFIRST=+$O(ORTMP(0))
  1.  S ORI=0
  1.  F  S ORI=$O(ORTMP(ORI)) Q:'ORI  D
  1.  . S X=$G(ORTMP(ORI))
  1.  . I ORFIRST=ORI,$E(X,1,3)=">> " S X=$E(X,4,999)
  1.  . I $L(X) D ADD^ORQ12
  1.  ;
  1.  ; Return message to the user
  1.  S ORMSG(1)="** This is a titrating RX; only the maintenance portion of the RX is being renewed. "
  1.  I ORNEWQTY>0 D
  1.  . S ORMSG(1)=ORMSG(1)_"Quantity has been changed from "_OROLDQTY_" to "_ORNEWQTY_". **"
  1.  E  D
  1.  . S ORMSG(1)=ORMSG(1)_"Please enter the updated Quantity. **"
  1.  ;
  1.  K ^TMP("ORWORD",$J)
  1.  ;
  1.  Q ORNEWQTY
  1.  ;
  1.  ; *******************************************
  1.  ; Returns TMP with dialog responses after editing them for titration renews.
  1.  ; Save responses in ORDIALOG() into ^TMP("ORWTITR",$J,ORIFN,4.5).
  1.  ;
  1. GETTMP(ORIFN) ;
  1.  ;
  1.  N CNT,INST,ITM,ORDIALOG,ORROOT,PROMPT,TYPE,VALUE
  1.  ;
  1.  K ^TMP("ORWTITR",$J)
  1.  ;
  1.  S ORDIALOG=$P($G(^OR(100,ORIFN,0)),U,5)
  1.  I ORDIALOG'["101.41," Q ""
  1.  S ORDIALOG=+ORDIALOG
  1.  D GETDLG^ORCD(ORDIALOG)
  1.  D GETORDER^ORCD(ORIFN)
  1.  D EDTDLG(.ORDIALOG,ORIFN)
  1.  ;
  1.  ;for the most part, copied this code from RESPONSE^ORCSAVE
  1.  S (PROMPT,CNT)=0
  1.  F  S PROMPT=$O(ORDIALOG(PROMPT)) Q:PROMPT'>0  D
  1.  . S ITM=$G(ORDIALOG(PROMPT)) Q:'ITM
  1.  . S TYPE=$E($G(ORDIALOG(PROMPT,0))) Q:'$L(TYPE)
  1.  . S INST=0
  1.  . F  S INST=$O(ORDIALOG(PROMPT,INST)) Q:INST'>0  D
  1.  . . S VALUE=$G(ORDIALOG(PROMPT,INST))
  1.  . . I VALUE="" Q
  1.  . . S CNT=CNT+1
  1.  . . S ^TMP("ORWTITR",$J,ORIFN,4.5,CNT,0)=+ITM_U_PROMPT_U_INST_U_$P(ITM,U,2)
  1.  . . S:$L($P(ITM,U,2)) ^TMP("ORWTITR",$J,ORIFN,4.5,"ID",$P(ITM,U,2),CNT)=""
  1.  . . I VALUE<1,TYPE="N" S VALUE=0_+VALUE I VALUE="00" S VALUE=0
  1.  . . S:TYPE'="W" ^TMP("ORWTITR",$J,ORIFN,4.5,CNT,1)=VALUE
  1.  . . M:TYPE="W" ^TMP("ORWTITR",$J,ORIFN,4.5,CNT,2)=@VALUE ; array root
  1.  ;
  1.  K ^TMP("ORWORD",$J)
  1.  S ORROOT=$NA(^TMP("ORWTITR",$J,ORIFN,4.5))
  1.  ;
  1.  Q ORROOT