ORWTITR ;ISP/LMT - Titrating RX Renewals ;Jul 27, 2018@06:49
;;3.0;ORDER ENTRY/RESULTS REPORTING;**405**;Dec 17, 1997;Build 211
;
;
; Reference to DOSE^PSSORUTL supported by ICR #3233
;
Q
;
; *******************************************************
; Edits Order Dialog Responses for titration renews.
; Only use responses after last "then".
EDTDLG(ORDIALOG,ORIFN) ;
;
N ORCHILD,ORCONJ,ORI,ORINSTR,ORLASTTHEN,ORM,ORSEQ,ORSIG
;
I '$G(ORDIALOG) S ORDIALOG=+$P($G(^OR(100,+ORIFN,0)),U,5)
;
S ORINSTR=$$PTR^ORCD("OR GTX INSTRUCTIONS")
S ORCONJ=$$PTR^ORCD("OR GTX AND/THEN")
S ORSIG=$$PTR^ORCD("OR GTX SIG")
;
; Find last "then" conjunction
S ORLASTTHEN=0
S ORI="00"
F S ORI=$O(ORDIALOG(ORCONJ,ORI),-1) Q:'ORI!(ORLASTTHEN) D
. I ORDIALOG(ORCONJ,ORI)="T" S ORLASTTHEN=ORI
I 'ORLASTTHEN Q
;
; Remove all responses for OR GTX INSTRUCTIONS that precede last "then"
D DELRESP(.ORDIALOG,ORINSTR,ORLASTTHEN)
;
; Remove all responses for children of OR GTX INSTRUCTIONS that precede last "then"
S ORSEQ=0
F S ORSEQ=$O(^ORD(101.41,ORDIALOG,10,"DAD",ORINSTR,ORSEQ)) Q:ORSEQ="" D
. S ORM=0
. F S ORM=$O(^ORD(101.41,ORDIALOG,10,"DAD",ORINSTR,ORSEQ,ORM)) Q:'ORM D
. . S ORCHILD=$P($G(^ORD(101.41,ORDIALOG,10,ORM,0)),U,2)
. . D DELRESP(.ORDIALOG,ORCHILD,ORLASTTHEN)
;
; recalculate QTY
; ** TODO - We might need to allow provider to change the QTY we calculate; need to ask Rob**
D QTY(.ORDIALOG,+ORIFN)
;
;Remove Titration response
D REMTITR(.ORDIALOG,+ORIFN)
;
; recalculate SIG
K ORDIALOG(ORSIG,1)
D SIG(.ORDIALOG,+ORIFN)
;
Q
;
;**********************
; deletes all dialog responses <= ORNUM
DELRESP(ORDIALOG,ORPTR,ORNUM) ;
;
N ORCNT,ORI,ORNEW
;
I '$D(ORDIALOG(ORPTR)) Q
;
; only keep responses > ORNUM
S ORCNT=0
S ORI=0
F S ORI=$O(ORDIALOG(ORPTR,ORI)) Q:'ORI D
. I ORI>ORNUM D
. . S ORCNT=ORCNT+1
. . S ORNEW(ORCNT)=ORDIALOG(ORPTR,ORI)
. K ORDIALOG(ORPTR,ORI)
M ORDIALOG(ORPTR)=ORNEW
;
; if there are no more responses left, kill the entire ORDIALOG entry
I '$O(ORDIALOG(ORPTR,0)) D Q
. S ORI=$$UP^XLFSTR($P($G(ORDIALOG(ORPTR,"A")),":",1))
. I ORI'="" K ORDIALOG("B",ORI)
. K ORDIALOG(ORPTR)
;
Q
;
;************************************
; Recalculates SIG
SIG(ORDIALOG,ORIFN) ;
;
N ORDOSE,ORDRUG,ORCAT,ORVP,ORWPSOI,PROMPT,DRUG
;
S ORVP=$P($G(^OR(100,+ORIFN,0)),U,2)
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) ; ICR #3233
D D1^ORCDPS2 ; set up ORDOSE
S DRUG=$G(ORDOSE("DD",+ORDRUG))
I DRUG,ORCAT="O" D RESETID^ORCDPS
D SIG^ORCDPS2
;
Q
;
;************************************
; Recalculates QTY
QTY(ORDIALOG,ORIFN) ;
;
N ORDRUG,ORDSUP,ORQTY,ORVP
;
S ORVP=$P($G(^OR(100,+ORIFN,0)),U,2)
S ORDRUG=$G(ORDIALOG($$PTR^ORCD("OR GTX DISPENSE DRUG"),1))
S ORDSUP=$G(ORDIALOG($$PTR^ORCD("OR GTX DAYS SUPPLY"),1))
;
S ORQTY=+$$QTY^ORCDPS1
;I ORQTY>0 S ORDIALOG($$PTR^ORCD("OR GTX QUANTITY"),1)=ORQTY
S ORDIALOG($$PTR^ORCD("OR GTX QUANTITY"),1)=ORQTY
;
Q
;
;************************************
; remove Titration response
REMTITR(ORDIALOG,ORIFN) ;
;
N ORTITR
;
S ORTITR=$$PTR^ORCD("OR GTX TITRATION")
D DELRESP(.ORDIALOG,ORTITR,1)
;
Q
;
; *************************************
; return Order Text based off updated ORDIALOG
ORDTXT(ORTXT,ORIFN,ORDIALOG) ;
;
N ORTX
;
D ORTX^ORCSAVE1(240)
M ORTXT=ORTX
;
Q
;
; *******************************************
; For renewals, Return new Order Text for titration order
; and new Qty
RNWFLDS(ORTX,ORMSG,ORIFN) ;
;
N ORDIALOG,ORFIRST,ORI,ORNEWQTY,OROLDQTY,ORTMP,WIDTH,X
;
S ORDIALOG=$P($G(^OR(100,ORIFN,0)),U,5)
I ORDIALOG'["101.41," Q ""
S ORDIALOG=+ORDIALOG
D GETDLG^ORCD(ORDIALOG)
D GETORDER^ORCD(+ORIFN)
S OROLDQTY=$G(ORDIALOG($$PTR^ORCD("OR GTX QUANTITY"),1))
D EDTDLG(.ORDIALOG,ORIFN)
S ORNEWQTY=$G(ORDIALOG($$PTR^ORCD("OR GTX QUANTITY"),1))
;
; Return Order Text
D ORDTXT(.ORTMP,ORIFN,.ORDIALOG)
S WIDTH=255
S ORTX=1
S ORTX(ORTX)=""
S ORFIRST=+$O(ORTMP(0))
S ORI=0
F S ORI=$O(ORTMP(ORI)) Q:'ORI D
. S X=$G(ORTMP(ORI))
. I ORFIRST=ORI,$E(X,1,3)=">> " S X=$E(X,4,999)
. I $L(X) D ADD^ORQ12
;
; Return message to the user
S ORMSG(1)="** This is a titrating RX; only the maintenance portion of the RX is being renewed. "
I ORNEWQTY>0 D
. S ORMSG(1)=ORMSG(1)_"Quantity has been changed from "_OROLDQTY_" to "_ORNEWQTY_". **"
E D
. S ORMSG(1)=ORMSG(1)_"Please enter the updated Quantity. **"
;
K ^TMP("ORWORD",$J)
;
Q ORNEWQTY
;
; *******************************************
; Returns TMP with dialog responses after editing them for titration renews.
; Save responses in ORDIALOG() into ^TMP("ORWTITR",$J,ORIFN,4.5).
;
GETTMP(ORIFN) ;
;
N CNT,INST,ITM,ORDIALOG,ORROOT,PROMPT,TYPE,VALUE
;
K ^TMP("ORWTITR",$J)
;
S ORDIALOG=$P($G(^OR(100,ORIFN,0)),U,5)
I ORDIALOG'["101.41," Q ""
S ORDIALOG=+ORDIALOG
D GETDLG^ORCD(ORDIALOG)
D GETORDER^ORCD(ORIFN)
D EDTDLG(.ORDIALOG,ORIFN)
;
;for the most part, copied this code from RESPONSE^ORCSAVE
S (PROMPT,CNT)=0
F S PROMPT=$O(ORDIALOG(PROMPT)) Q:PROMPT'>0 D
. S ITM=$G(ORDIALOG(PROMPT)) Q:'ITM
. S TYPE=$E($G(ORDIALOG(PROMPT,0))) Q:'$L(TYPE)
. S INST=0
. F S INST=$O(ORDIALOG(PROMPT,INST)) Q:INST'>0 D
. . S VALUE=$G(ORDIALOG(PROMPT,INST))
. . I VALUE="" Q
. . S CNT=CNT+1
. . S ^TMP("ORWTITR",$J,ORIFN,4.5,CNT,0)=+ITM_U_PROMPT_U_INST_U_$P(ITM,U,2)
. . S:$L($P(ITM,U,2)) ^TMP("ORWTITR",$J,ORIFN,4.5,"ID",$P(ITM,U,2),CNT)=""
. . I VALUE<1,TYPE="N" S VALUE=0_+VALUE I VALUE="00" S VALUE=0
. . S:TYPE'="W" ^TMP("ORWTITR",$J,ORIFN,4.5,CNT,1)=VALUE
. . M:TYPE="W" ^TMP("ORWTITR",$J,ORIFN,4.5,CNT,2)=@VALUE ; array root
;
K ^TMP("ORWORD",$J)
S ORROOT=$NA(^TMP("ORWTITR",$J,ORIFN,4.5))
;
Q ORROOT
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORWTITR 6153 printed Apr 09, 2024@21:44:31 Page 2
ORWTITR ;ISP/LMT - Titrating RX Renewals ;Jul 27, 2018@06:49
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**405**;Dec 17, 1997;Build 211
+2 ;
+3 ;
+4 ; Reference to DOSE^PSSORUTL supported by ICR #3233
+5 ;
+6 QUIT
+7 ;
+8 ; *******************************************************
+9 ; Edits Order Dialog Responses for titration renews.
+10 ; Only use responses after last "then".
EDTDLG(ORDIALOG,ORIFN) ;
+1 ;
+2 NEW ORCHILD,ORCONJ,ORI,ORINSTR,ORLASTTHEN,ORM,ORSEQ,ORSIG
+3 ;
+4 IF '$GET(ORDIALOG)
SET ORDIALOG=+$PIECE($GET(^OR(100,+ORIFN,0)),U,5)
+5 ;
+6 SET ORINSTR=$$PTR^ORCD("OR GTX INSTRUCTIONS")
+7 SET ORCONJ=$$PTR^ORCD("OR GTX AND/THEN")
+8 SET ORSIG=$$PTR^ORCD("OR GTX SIG")
+9 ;
+10 ; Find last "then" conjunction
+11 SET ORLASTTHEN=0
+12 SET ORI="00"
+13 FOR
SET ORI=$ORDER(ORDIALOG(ORCONJ,ORI),-1)
if 'ORI!(ORLASTTHEN)
QUIT
Begin DoDot:1
+14 IF ORDIALOG(ORCONJ,ORI)="T"
SET ORLASTTHEN=ORI
End DoDot:1
+15 IF 'ORLASTTHEN
QUIT
+16 ;
+17 ; Remove all responses for OR GTX INSTRUCTIONS that precede last "then"
+18 DO DELRESP(.ORDIALOG,ORINSTR,ORLASTTHEN)
+19 ;
+20 ; Remove all responses for children of OR GTX INSTRUCTIONS that precede last "then"
+21 SET ORSEQ=0
+22 FOR
SET ORSEQ=$ORDER(^ORD(101.41,ORDIALOG,10,"DAD",ORINSTR,ORSEQ))
if ORSEQ=""
QUIT
Begin DoDot:1
+23 SET ORM=0
+24 FOR
SET ORM=$ORDER(^ORD(101.41,ORDIALOG,10,"DAD",ORINSTR,ORSEQ,ORM))
if 'ORM
QUIT
Begin DoDot:2
+25 SET ORCHILD=$PIECE($GET(^ORD(101.41,ORDIALOG,10,ORM,0)),U,2)
+26 DO DELRESP(.ORDIALOG,ORCHILD,ORLASTTHEN)
End DoDot:2
End DoDot:1
+27 ;
+28 ; recalculate QTY
+29 ; ** TODO - We might need to allow provider to change the QTY we calculate; need to ask Rob**
+30 DO QTY(.ORDIALOG,+ORIFN)
+31 ;
+32 ;Remove Titration response
+33 DO REMTITR(.ORDIALOG,+ORIFN)
+34 ;
+35 ; recalculate SIG
+36 KILL ORDIALOG(ORSIG,1)
+37 DO SIG(.ORDIALOG,+ORIFN)
+38 ;
+39 QUIT
+40 ;
+41 ;**********************
+42 ; deletes all dialog responses <= ORNUM
DELRESP(ORDIALOG,ORPTR,ORNUM) ;
+1 ;
+2 NEW ORCNT,ORI,ORNEW
+3 ;
+4 IF '$DATA(ORDIALOG(ORPTR))
QUIT
+5 ;
+6 ; only keep responses > ORNUM
+7 SET ORCNT=0
+8 SET ORI=0
+9 FOR
SET ORI=$ORDER(ORDIALOG(ORPTR,ORI))
if 'ORI
QUIT
Begin DoDot:1
+10 IF ORI>ORNUM
Begin DoDot:2
+11 SET ORCNT=ORCNT+1
+12 SET ORNEW(ORCNT)=ORDIALOG(ORPTR,ORI)
End DoDot:2
+13 KILL ORDIALOG(ORPTR,ORI)
End DoDot:1
+14 MERGE ORDIALOG(ORPTR)=ORNEW
+15 ;
+16 ; if there are no more responses left, kill the entire ORDIALOG entry
+17 IF '$ORDER(ORDIALOG(ORPTR,0))
Begin DoDot:1
+18 SET ORI=$$UP^XLFSTR($PIECE($GET(ORDIALOG(ORPTR,"A")),":",1))
+19 IF ORI'=""
KILL ORDIALOG("B",ORI)
+20 KILL ORDIALOG(ORPTR)
End DoDot:1
QUIT
+21 ;
+22 QUIT
+23 ;
+24 ;************************************
+25 ; Recalculates SIG
SIG(ORDIALOG,ORIFN) ;
+1 ;
+2 NEW ORDOSE,ORDRUG,ORCAT,ORVP,ORWPSOI,PROMPT,DRUG
+3 ;
+4 SET ORVP=$PIECE($GET(^OR(100,+ORIFN,0)),U,2)
+5 SET ORCAT=$PIECE($GET(^OR(100,+ORIFN,0)),U,12)
+6 SET PROMPT=$$PTR^ORCD("OR GTX INSTRUCTIONS")
+7 SET ORDRUG=$GET(ORDIALOG($$PTR^ORCD("OR GTX DISPENSE DRUG"),1))
+8 SET ORWPSOI=+$GET(ORDIALOG($$PTR^ORCD("OR GTX ORDERABLE ITEM"),1))
+9 IF ORWPSOI
SET ORWPSOI=+$PIECE($GET(^ORD(101.43,+ORWPSOI,0)),U,2)
+10 ; ICR #3233
DO DOSE^PSSORUTL(.ORDOSE,ORWPSOI,$SELECT(ORCAT="I":"U",1:"O"),ORVP)
+11 ; set up ORDOSE
DO D1^ORCDPS2
+12 SET DRUG=$GET(ORDOSE("DD",+ORDRUG))
+13 IF DRUG
IF ORCAT="O"
DO RESETID^ORCDPS
+14 DO SIG^ORCDPS2
+15 ;
+16 QUIT
+17 ;
+18 ;************************************
+19 ; Recalculates QTY
QTY(ORDIALOG,ORIFN) ;
+1 ;
+2 NEW ORDRUG,ORDSUP,ORQTY,ORVP
+3 ;
+4 SET ORVP=$PIECE($GET(^OR(100,+ORIFN,0)),U,2)
+5 SET ORDRUG=$GET(ORDIALOG($$PTR^ORCD("OR GTX DISPENSE DRUG"),1))
+6 SET ORDSUP=$GET(ORDIALOG($$PTR^ORCD("OR GTX DAYS SUPPLY"),1))
+7 ;
+8 SET ORQTY=+$$QTY^ORCDPS1
+9 ;I ORQTY>0 S ORDIALOG($$PTR^ORCD("OR GTX QUANTITY"),1)=ORQTY
+10 SET ORDIALOG($$PTR^ORCD("OR GTX QUANTITY"),1)=ORQTY
+11 ;
+12 QUIT
+13 ;
+14 ;************************************
+15 ; remove Titration response
REMTITR(ORDIALOG,ORIFN) ;
+1 ;
+2 NEW ORTITR
+3 ;
+4 SET ORTITR=$$PTR^ORCD("OR GTX TITRATION")
+5 DO DELRESP(.ORDIALOG,ORTITR,1)
+6 ;
+7 QUIT
+8 ;
+9 ; *************************************
+10 ; return Order Text based off updated ORDIALOG
ORDTXT(ORTXT,ORIFN,ORDIALOG) ;
+1 ;
+2 NEW ORTX
+3 ;
+4 DO ORTX^ORCSAVE1(240)
+5 MERGE ORTXT=ORTX
+6 ;
+7 QUIT
+8 ;
+9 ; *******************************************
+10 ; For renewals, Return new Order Text for titration order
+11 ; and new Qty
RNWFLDS(ORTX,ORMSG,ORIFN) ;
+1 ;
+2 NEW ORDIALOG,ORFIRST,ORI,ORNEWQTY,OROLDQTY,ORTMP,WIDTH,X
+3 ;
+4 SET ORDIALOG=$PIECE($GET(^OR(100,ORIFN,0)),U,5)
+5 IF ORDIALOG'["101.41,"
QUIT ""
+6 SET ORDIALOG=+ORDIALOG
+7 DO GETDLG^ORCD(ORDIALOG)
+8 DO GETORDER^ORCD(+ORIFN)
+9 SET OROLDQTY=$GET(ORDIALOG($$PTR^ORCD("OR GTX QUANTITY"),1))
+10 DO EDTDLG(.ORDIALOG,ORIFN)
+11 SET ORNEWQTY=$GET(ORDIALOG($$PTR^ORCD("OR GTX QUANTITY"),1))
+12 ;
+13 ; Return Order Text
+14 DO ORDTXT(.ORTMP,ORIFN,.ORDIALOG)
+15 SET WIDTH=255
+16 SET ORTX=1
+17 SET ORTX(ORTX)=""
+18 SET ORFIRST=+$ORDER(ORTMP(0))
+19 SET ORI=0
+20 FOR
SET ORI=$ORDER(ORTMP(ORI))
if 'ORI
QUIT
Begin DoDot:1
+21 SET X=$GET(ORTMP(ORI))
+22 IF ORFIRST=ORI
IF $EXTRACT(X,1,3)=">> "
SET X=$EXTRACT(X,4,999)
+23 IF $LENGTH(X)
DO ADD^ORQ12
End DoDot:1
+24 ;
+25 ; Return message to the user
+26 SET ORMSG(1)="** This is a titrating RX; only the maintenance portion of the RX is being renewed. "
+27 IF ORNEWQTY>0
Begin DoDot:1
+28 SET ORMSG(1)=ORMSG(1)_"Quantity has been changed from "_OROLDQTY_" to "_ORNEWQTY_". **"
End DoDot:1
+29 IF '$TEST
Begin DoDot:1
+30 SET ORMSG(1)=ORMSG(1)_"Please enter the updated Quantity. **"
End DoDot:1
+31 ;
+32 KILL ^TMP("ORWORD",$JOB)
+33 ;
+34 QUIT ORNEWQTY
+35 ;
+36 ; *******************************************
+37 ; Returns TMP with dialog responses after editing them for titration renews.
+38 ; Save responses in ORDIALOG() into ^TMP("ORWTITR",$J,ORIFN,4.5).
+39 ;
GETTMP(ORIFN) ;
+1 ;
+2 NEW CNT,INST,ITM,ORDIALOG,ORROOT,PROMPT,TYPE,VALUE
+3 ;
+4 KILL ^TMP("ORWTITR",$JOB)
+5 ;
+6 SET ORDIALOG=$PIECE($GET(^OR(100,ORIFN,0)),U,5)
+7 IF ORDIALOG'["101.41,"
QUIT ""
+8 SET ORDIALOG=+ORDIALOG
+9 DO GETDLG^ORCD(ORDIALOG)
+10 DO GETORDER^ORCD(ORIFN)
+11 DO EDTDLG(.ORDIALOG,ORIFN)
+12 ;
+13 ;for the most part, copied this code from RESPONSE^ORCSAVE
+14 SET (PROMPT,CNT)=0
+15 FOR
SET PROMPT=$ORDER(ORDIALOG(PROMPT))
if PROMPT'>0
QUIT
Begin DoDot:1
+16 SET ITM=$GET(ORDIALOG(PROMPT))
if 'ITM
QUIT
+17 SET TYPE=$EXTRACT($GET(ORDIALOG(PROMPT,0)))
if '$LENGTH(TYPE)
QUIT
+18 SET INST=0
+19 FOR
SET INST=$ORDER(ORDIALOG(PROMPT,INST))
if INST'>0
QUIT
Begin DoDot:2
+20 SET VALUE=$GET(ORDIALOG(PROMPT,INST))
+21 IF VALUE=""
QUIT
+22 SET CNT=CNT+1
+23 SET ^TMP("ORWTITR",$JOB,ORIFN,4.5,CNT,0)=+ITM_U_PROMPT_U_INST_U_$PIECE(ITM,U,2)
+24 if $LENGTH($PIECE(ITM,U,2))
SET ^TMP("ORWTITR",$JOB,ORIFN,4.5,"ID",$PIECE(ITM,U,2),CNT)=""
+25 IF VALUE<1
IF TYPE="N"
SET VALUE=0_+VALUE
IF VALUE="00"
SET VALUE=0
+26 if TYPE'="W"
SET ^TMP("ORWTITR",$JOB,ORIFN,4.5,CNT,1)=VALUE
+27 ; array root
if TYPE="W"
MERGE ^TMP("ORWTITR",$JOB,ORIFN,4.5,CNT,2)=@VALUE
End DoDot:2
End DoDot:1
+28 ;
+29 KILL ^TMP("ORWORD",$JOB)
+30 SET ORROOT=$NAME(^TMP("ORWTITR",$JOB,ORIFN,4.5))
+31 ;
+32 QUIT ORROOT
