ORAREN ;SLC/JLC - PROCESS RENEWAL REQUEST ;Apr 07, 2022@14:23:48
;;3.0;ORDER ENTRY/RESULTS REPORTING;**336,349,350,540,405**;Dec 17, 1997;Build 211
;
;The purpose of this API is to process a request to renew an
;Outpatient Prescription
;
; DBIA 2790 - ACTVSURO^XQALSURO
; DBIA 2343 - ACTIVE^XUSER
; DBIA 2848 - GETALL^SCAPMCA
; DBIA 2263 - GET^XPAR
;
Q
RENEW(ORRESULT,DFN,RX,PROVP,RENEWF) ;
;Input - DFN of the patient
; RX to be renewed
;
; One assumption is made for now and that is that the TMP globals and the message counters are
; initialized by the calling routine. Not a perfect scenario, but in order to batch the mail
; messages that is what was done.
;*349 Added passing to build the message for variable safety. And mail reformat.
N X,OK,ORY,ORPKG,ORITM,ORIFN,PSOSTAT,A,PDET,ORFLDS,DRUG,DISPLAY,FAIL,LIST,OCHKS,OCO,OCLIST,ORCPLX,ORINFO,ORPVSTS
N ORL,ORPROV,PCP,PCPN,RNWFLDS,Y,ORUSR,NEWIFN,PNM,RXE,EMSG,INMSG,ORPROVNM ;*349
K ^TMP("SC",$J) S RENEWF=$G(RENEWF)
I $G(PROVP)="" S PROVP="A"
S PNM=$P($G(^DPT(DFN,0)),U),ORUSR=$$GET^XPAR("SYS","OR AUTORENEWAL USER") I ORUSR="" D AE(.EMSG,RX,DFN,"No auto-renewal user defined") S ORRESULT=0 G END
D EN^PSOORDER(DFN,RX)
S DRUG=$P($G(^TMP("PSOR",$J,RX,"DRUG",0)),U,2)
S:DRUG="" DRUG=$P($P($G(^TMP("PSOR",$J,RX,"DRUG",0)),U),";",2)
S PSOSTAT=$P($P($G(^TMP("PSOR",$J,RX,0)),U,4),";") I PSOSTAT'="A",PSOSTAT'="E" D AE(.EMSG,RX,DFN,"RX Status Not Active or Expired") S ORRESULT=0 G END
D LOCK^ORWDX(.OK,DFN) I 'OK D AE(.EMSG,RX,DFN,"Chart Lock Failed") S ORRESULT=0 G END
S ORIFN=$P($G(^TMP("PSOR",$J,RX,1)),U,8) I ORIFN="" D AE(.EMSG,RX,DFN,"No CPRS Order Number") S ORRESULT=0 G UNLOCK
I RENEWF="N" D G UNLOCK
.D AE(.EMSG,RX,DFN,"Drug not renewable")
.D EN^ORB3(73,DFN,ORIFN,"","Non-Renewable RX Request for "_DRUG,"NEW;"_ORIFN)
.S ORRESULT=0
D LOCKORD^ORWDX(.OK,ORIFN) I 'OK D AE(.EMSG,RX,DFN,"Order Lock Failed") S ORRESULT=0 G UNLOCK
S A=$G(^OR(100,ORIFN,0)) I A="" D AE(.EMSG,RX,DFN,"Order missing from ORDERS file") S ORRESULT=0 G UNO
S ORPROV=+$P(A,U,4),ORL=+$P(A,U,10)
;*349 Add Provider name, check valid surogate
S ORPROVNM=$$GET1^DIQ(200,ORPROV,.01,"E"),ORPVSTS=$$ACTIVE^XUSER(ORPROV)
I ORPROVNM]"" S ORPROVNM="("_ORPROVNM_")"
I '$G(ORPVSTS)&($$ACTVSURO^XQALSURO(ORPROV)<1) D AE(.EMSG,RX,DFN,"Provider "_ORPROVNM_$S(ORPVSTS="":" NOT FOUND",1:" flagged as "_$P(ORPVSTS,U,2))) S ORRESULT=0 G UNO
S PCPN=$$GETALL^SCAPMCA(DFN),PCP=+$G(^TMP("SC",$J,DFN,"PCPR",1))
I PROVP="P",ORPROV'=PCP D AE(.EMSG,RX,DFN,"Ordering Provider "_ORPROVNM_" not Primary Care") S ORRESULT=3 G UNO
D ALLWORD^ORALWORD(.ORY,DFN,ORIFN,"E",ORPROV) I $G(ORY)>0 D AE(.EMSG,RX,DFN,"Clozapine Failed - details below",.ORY) S ORRESULT=0 G UNO
D VALID^ORWDXA(.ORY,ORIFN,"RN",ORPROV)
I $G(ORY)]"" D G UNO
.D AE(.EMSG,RX,DFN,"Invalid Action - details below",.ORY)
.D:$$UP^XLFSTR(ORY)["NON-RENEWABLE" EN^ORB3(73,DFN,ORIFN,"","Non-Renewable RX Request for "_DRUG,"NEW;"_ORIFN)
.S ORRESULT=0
D GETPKG^ORWDXR(.ORPKG,ORIFN) I '$D(ORPKG) D AE(.EMSG,RX,DFN,"Invalid Order Number") S ORRESULT=0 G UNO
I ORPKG'="PSO" D AE(.EMSG,RX,DFN,"Problem with package in ORDERS file") S ORRESULT=0 G UNO
D GTORITM^ORWDXR(.ORITM,ORIFN)
D FAILDEA^ORWDPS1(.FAIL,ORITM,ORPROV,"O") I FAIL D AE(.EMSG,RX,DFN,"Failed DEA Check") S ORRESULT=0 G UNO
;*349 Maintain AUDIO RENEWAL USER on pharmacy side.
D RNWFLDS^ORWDXR(.RNWFLDS,ORIFN) S ORFLDS(1)=RNWFLDS(0),ORFLDS("ORDUZ")=ORUSR
D CHKGRP^ORWDPS2(.DISPLAY,ORIFN) I DISPLAY'=2 D AE(.EMSG,RX,DFN,"Package Problem on Order") S ORRESULT=0 G UNO
D ON^ORWDXC(.OCO)
D DISPLAY^ORWDXC(.OCLIST,DFN,ORPKG) I $D(OCLIST) D INFO(.INMSG,RX,DFN,.OCLIST)
D OXDATA^ORWDXR01(.ORINFO,ORIFN)
S ORINFO(1)=ORINFO
D ACCEPT^ORWDXC(.OCHKS,DFN,"PSO","",ORL,.ORINFO,ORIFN,1)
I $D(OCHKS) D INFO(.INMSG,RX,DFN,.OCHKS)
D ISCPLX^ORWDXR(.ORCPLX,ORIFN) S ORCPLX=+$G(ORCPLX)
S (CNT,S1)=0 F S S1=$O(OCHKS(S1)) Q:'S1 S CNT=CNT+1,ORFLDS("ORCHECK",$P(OCHKS(S1),U),$P(OCHKS(S1),U,3),CNT)=$P(OCHKS(S1),U,2,99)
I CNT>0 S ORFLDS("ORCHECK")=CNT
D RENEW^ORWDXR(.LIST,ORIFN,DFN,ORPROV,ORL,.ORFLDS,ORCPLX,0) S ORRESULT=1
S NEWIFN=$P(^OR(100,ORIFN,3),U,6)
S $P(^OR(100,NEWIFN,8,1,0),U,13)=ORUSR
D UNSIGNED(NEWIFN)
D KILUNSNO^ORWORB(.Y,DFN)
D KILEXMED^ORWORB(.Y,DFN)
UNO D UNLKORD^ORWDX(.OK,ORIFN)
UNLOCK D UNLOCK^ORWDX(.OK,DFN)
;
END ;*249 Modify END.
;Merge Message Arrays into ^TMP( for VEXRX, add header if needed.
N I,J,RXELN,DRGLN,DSPNMLN,SPACE
S SPACE=$J(" ",40)
S RXELN=$$GET1^DID(52,.01,"","FIELD LENGTH"),DRGLN=$$GET1^DID(52,6,"","FIELD LENGTH"),DSPNMLN=$$GET1^DID(2,.01,"","FIELD LENGTH")
I $D(EMSG) D
. S J=$O(^TMP($J,"ORAREN E",""),-1)+1
. I J<2 D
. . S ^TMP($J,"ORAREN E",J,0)="Renewal Requests Not Sent to Provider",J=J+1
. . S ^TMP($J,"ORAREN E",J,0)=" ",J=J+1
. . S ^TMP($J,"ORAREN E",J,0)=$E("PATIENT"_SPACE,0,DSPNMLN)_" "_$E("RX#"_SPACE,0,RXELN)_" "_$E("DRUG"_SPACE,0,DRGLN),J=J+1
. . S ^TMP($J,"ORAREN E",J,0)=" PROBLEM",J=J+1
. . S ^TMP($J,"ORAREN E",J,0)="==============================================================================",J=J+1
. . S ^TMP($J,"ORAREN E",J,0)=" ",J=J+1
. F I=0:0 S I=$O(EMSG(I)) Q:'I S ^TMP($J,"ORAREN E",J,0)=EMSG(I),J=J+1
I $D(INMSG) D
. S J=$O(^TMP($J,"ORAREN OC",""),-1)+1
. I J<2 D
. . S ^TMP($J,"ORAREN OC",J,0)="Renewal Requests with Order Checks",J=J+1
. . S ^TMP($J,"ORAREN OC",J,0)=" ",J=J+1
. . S ^TMP($J,"ORAREN OC",J,0)=$E("PATIENT"_SPACE,0,DSPNMLN)_" "_$E("RX#"_SPACE,0,RXELN)_" "_$E("DRUG"_SPACE,0,DRGLN),J=J+1
. . S ^TMP($J,"ORAREN OC",J,0)="==============================================================================",J=J+1
. . S ^TMP($J,"ORAREN OC",J,0)=" ",J=J+1
. ;OR*3.0*540: Break up order check lines greater than 500 characters
. F I=0:0 S I=$O(INMSG(I)) Q:'I D
. . I $L(INMSG(I))<500 S ^TMP($J,"ORAREN OC",J,0)=INMSG(I),J=J+1 Q
. . D SEG
D CLRALLGY^ORWDXC("",DFN)
Q
;
SEG ;break up lines longer than 500 characters
N ORLEN,OREND,ORSQ,ORX1,ORX2
S ORLEN=$L(INMSG(I)),OREND=ORLEN/500
;Round number of iterations to next whole number.
S OREND=$S($P(OREND,".",2)>0:$P(OREND,".")+1,1:$P(OREND,"."))
F ORSQ=1:1:OREND D
. S ORX1=(ORSQ-1*500)+1
. S ORX2=ORSQ*500
. S ^TMP($J,"ORAREN OC",J,0)=$E(INMSG(I),ORX1,ORX2)
. S J=J+1
Q
;
AE(MSARY,RX,DFN,TEXT,PDET) ;*349
;Input: MSARY - Output aray
; RX - Internal RX#
; DFN - Internal Patient DFN
;Output: MSARY will be appended with a line pertaining to the input.
;
N I,S1,SPACE,CNT,RXE,DRG,PNM,SSN,SSID,SPACE S SPACE=$J(" ",40),CNT=1
N RXELN,DRGLN,DSPNMLN
S RXE=$$GET1^DIQ(52,RX,.01,"E"),DRG=$$GET1^DIQ(52,RX,6,"E"),PNM=$$GET1^DIQ(2,DFN,.01,"E"),SSN=+$$GET1^DIQ(2,DFN,.09,"E")
S RXELN=$$GET1^DID(52,.01,"","FIELD LENGTH"),DRGLN=$$GET1^DID(52,6,"","FIELD LENGTH"),DSPNMLN=$$GET1^DID(2,.01,"","FIELD LENGTH")
S SSID="("_$E(PNM,1)_$E(SSN,$L(SSN)-3,$L(SSN))_")"
S DSPNM=$E(PNM,1,DSPNMLN-$L(" "_SSID))_" "_SSID ;Have to truncate Patient name if it is too long.
F I="DSPNM","RXE","DRG" S MSARY(CNT)=$G(MSARY(CNT))_$E(@I_SPACE,1,@(I_"LN"))_" "
S CNT=CNT+1
S MSARY(CNT)=$E(SPACE,0,4)_TEXT,CNT=CNT+1
I $D(PDET),$O(PDET(0))="" S MSARY(CNT)=$E(SPACE,0,4)_PDET,CNT=CNT+1 Q
I $D(PDET) S S1=0 F S S1=$O(PDET(S1)) Q:'S1 S MSARY(CNT)=$E(SPACE,0,4)_PDET(S1),CNT=CNT+1
Q
;
INFO(INARY,RX,DFN,MSG) ;file informational items in mail message ;*349
;Input: INARY - Output aray
; RX - Internal RX#
; DFN - Internal Patient DFN
; MSG - Message Array
;Output: INARY will be appended with a line pertaining to the input.
;
N I,SPACE,CNT,RXE,DRG,PNM,SSN,SSID,DSPNM,SPACE,S1 S SPACE=$J(" ",40),CNT=1
N RXELN,DRGLN,DSPNMLN
I $D(INARY) S CNT=$O(INARY(""),-1)
I '$D(INARY) D
. S RXE=$$GET1^DIQ(52,RX,.01,"E"),DRG=$$GET1^DIQ(52,RX,6,"E"),PNM=$$GET1^DIQ(2,DFN,.01,"E"),SSN=+$$GET1^DIQ(2,DFN,.09,"E")
. S RXELN=$$GET1^DID(52,.01,"","FIELD LENGTH"),DRGLN=$$GET1^DID(52,6,"","FIELD LENGTH"),DSPNMLN=$$GET1^DID(2,.01,"","FIELD LENGTH")
. S SSID="("_$E(PNM,1)_$E(SSN,$L(SSN)-3,$L(SSN))_")"
. S DSPNM=$E(PNM,1,DSPNMLN-$L(" "_SSID))_" "_SSID ;Have to truncate Patient name if it is too long.
. F I="DSPNM","RXE","DRG" S INARY(CNT)=$G(INARY(CNT))_$E(@I_SPACE,0,@(I_"LN"))_" "
S CNT=CNT+1,INARY(CNT)=" ",CNT=CNT+1,S1=0
F S S1=$O(MSG(S1)) Q:'S1 D S INARY(CNT)=" ",CNT=CNT+1
. I $L(MSG(S1),U)>2 S INARY(CNT)=$P(MSG(S1),U,4,99),CNT=CNT+1 Q
. S INARY(CNT)=$E(SPACE,0,5)_MSG(S1),CNT=CNT+1
Q
UNSIGNED(UIFN) ;queue unsigned order alert
N ORVP,ORIFN,ORNP,A
Q:$G(UIFN)="" S A=$G(^OR(100,UIFN,0)),ORVP=$P(A,U,2),ORNP=$P(A,U,4),ORIFN=UIFN_";1"
D NOTIF^ORCSIGN
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORAREN 8713 printed Apr 09, 2024@21:42:54 Page 2
ORAREN ;SLC/JLC - PROCESS RENEWAL REQUEST ;Apr 07, 2022@14:23:48
+1 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**336,349,350,540,405**;Dec 17, 1997;Build 211
+2 ;
+3 ;The purpose of this API is to process a request to renew an
+4 ;Outpatient Prescription
+5 ;
+6 ; DBIA 2790 - ACTVSURO^XQALSURO
+7 ; DBIA 2343 - ACTIVE^XUSER
+8 ; DBIA 2848 - GETALL^SCAPMCA
+9 ; DBIA 2263 - GET^XPAR
+10 ;
+11 QUIT
RENEW(ORRESULT,DFN,RX,PROVP,RENEWF) ;
+1 ;Input - DFN of the patient
+2 ; RX to be renewed
+3 ;
+4 ; One assumption is made for now and that is that the TMP globals and the message counters are
+5 ; initialized by the calling routine. Not a perfect scenario, but in order to batch the mail
+6 ; messages that is what was done.
+7 ;*349 Added passing to build the message for variable safety. And mail reformat.
+8 NEW X,OK,ORY,ORPKG,ORITM,ORIFN,PSOSTAT,A,PDET,ORFLDS,DRUG,DISPLAY,FAIL,LIST,OCHKS,OCO,OCLIST,ORCPLX,ORINFO,ORPVSTS
+9 ;*349
NEW ORL,ORPROV,PCP,PCPN,RNWFLDS,Y,ORUSR,NEWIFN,PNM,RXE,EMSG,INMSG,ORPROVNM
+10 KILL ^TMP("SC",$JOB)
SET RENEWF=$GET(RENEWF)
+11 IF $GET(PROVP)=""
SET PROVP="A"
+12 SET PNM=$PIECE($GET(^DPT(DFN,0)),U)
SET ORUSR=$$GET^XPAR("SYS","OR AUTORENEWAL USER")
IF ORUSR=""
DO AE(.EMSG,RX,DFN,"No auto-renewal user defined")
SET ORRESULT=0
GOTO END
+13 DO EN^PSOORDER(DFN,RX)
+14 SET DRUG=$PIECE($GET(^TMP("PSOR",$JOB,RX,"DRUG",0)),U,2)
+15 if DRUG=""
SET DRUG=$PIECE($PIECE($GET(^TMP("PSOR",$JOB,RX,"DRUG",0)),U),";",2)
+16 SET PSOSTAT=$PIECE($PIECE($GET(^TMP("PSOR",$JOB,RX,0)),U,4),";")
IF PSOSTAT'="A"
IF PSOSTAT'="E"
DO AE(.EMSG,RX,DFN,"RX Status Not Active or Expired")
SET ORRESULT=0
GOTO END
+17 DO LOCK^ORWDX(.OK,DFN)
IF 'OK
DO AE(.EMSG,RX,DFN,"Chart Lock Failed")
SET ORRESULT=0
GOTO END
+18 SET ORIFN=$PIECE($GET(^TMP("PSOR",$JOB,RX,1)),U,8)
IF ORIFN=""
DO AE(.EMSG,RX,DFN,"No CPRS Order Number")
SET ORRESULT=0
GOTO UNLOCK
+19 IF RENEWF="N"
Begin DoDot:1
+20 DO AE(.EMSG,RX,DFN,"Drug not renewable")
+21 DO EN^ORB3(73,DFN,ORIFN,"","Non-Renewable RX Request for "_DRUG,"NEW;"_ORIFN)
+22 SET ORRESULT=0
End DoDot:1
GOTO UNLOCK
+23 DO LOCKORD^ORWDX(.OK,ORIFN)
IF 'OK
DO AE(.EMSG,RX,DFN,"Order Lock Failed")
SET ORRESULT=0
GOTO UNLOCK
+24 SET A=$GET(^OR(100,ORIFN,0))
IF A=""
DO AE(.EMSG,RX,DFN,"Order missing from ORDERS file")
SET ORRESULT=0
GOTO UNO
+25 SET ORPROV=+$PIECE(A,U,4)
SET ORL=+$PIECE(A,U,10)
+26 ;*349 Add Provider name, check valid surogate
+27 SET ORPROVNM=$$GET1^DIQ(200,ORPROV,.01,"E")
SET ORPVSTS=$$ACTIVE^XUSER(ORPROV)
+28 IF ORPROVNM]""
SET ORPROVNM="("_ORPROVNM_")"
+29 IF '$GET(ORPVSTS)&($$ACTVSURO^XQALSURO(ORPROV)<1)
DO AE(.EMSG,RX,DFN,"Provider "_ORPROVNM_$SELECT(ORPVSTS="":" NOT FOUND",1:" flagged as "_$PIECE(ORPVSTS,U,2)))
SET ORRESULT=0
GOTO UNO
+30 SET PCPN=$$GETALL^SCAPMCA(DFN)
SET PCP=+$GET(^TMP("SC",$JOB,DFN,"PCPR",1))
+31 IF PROVP="P"
IF ORPROV'=PCP
DO AE(.EMSG,RX,DFN,"Ordering Provider "_ORPROVNM_" not Primary Care")
SET ORRESULT=3
GOTO UNO
+32 DO ALLWORD^ORALWORD(.ORY,DFN,ORIFN,"E",ORPROV)
IF $GET(ORY)>0
DO AE(.EMSG,RX,DFN,"Clozapine Failed - details below",.ORY)
SET ORRESULT=0
GOTO UNO
+33 DO VALID^ORWDXA(.ORY,ORIFN,"RN",ORPROV)
+34 IF $GET(ORY)]""
Begin DoDot:1
+35 DO AE(.EMSG,RX,DFN,"Invalid Action - details below",.ORY)
+36 if $$UP^XLFSTR(ORY)["NON-RENEWABLE"
DO EN^ORB3(73,DFN,ORIFN,"","Non-Renewable RX Request for "_DRUG,"NEW;"_ORIFN)
+37 SET ORRESULT=0
End DoDot:1
GOTO UNO
+38 DO GETPKG^ORWDXR(.ORPKG,ORIFN)
IF '$DATA(ORPKG)
DO AE(.EMSG,RX,DFN,"Invalid Order Number")
SET ORRESULT=0
GOTO UNO
+39 IF ORPKG'="PSO"
DO AE(.EMSG,RX,DFN,"Problem with package in ORDERS file")
SET ORRESULT=0
GOTO UNO
+40 DO GTORITM^ORWDXR(.ORITM,ORIFN)
+41 DO FAILDEA^ORWDPS1(.FAIL,ORITM,ORPROV,"O")
IF FAIL
DO AE(.EMSG,RX,DFN,"Failed DEA Check")
SET ORRESULT=0
GOTO UNO
+42 ;*349 Maintain AUDIO RENEWAL USER on pharmacy side.
+43 DO RNWFLDS^ORWDXR(.RNWFLDS,ORIFN)
SET ORFLDS(1)=RNWFLDS(0)
SET ORFLDS("ORDUZ")=ORUSR
+44 DO CHKGRP^ORWDPS2(.DISPLAY,ORIFN)
IF DISPLAY'=2
DO AE(.EMSG,RX,DFN,"Package Problem on Order")
SET ORRESULT=0
GOTO UNO
+45 DO ON^ORWDXC(.OCO)
+46 DO DISPLAY^ORWDXC(.OCLIST,DFN,ORPKG)
IF $DATA(OCLIST)
DO INFO(.INMSG,RX,DFN,.OCLIST)
+47 DO OXDATA^ORWDXR01(.ORINFO,ORIFN)
+48 SET ORINFO(1)=ORINFO
+49 DO ACCEPT^ORWDXC(.OCHKS,DFN,"PSO","",ORL,.ORINFO,ORIFN,1)
+50 IF $DATA(OCHKS)
DO INFO(.INMSG,RX,DFN,.OCHKS)
+51 DO ISCPLX^ORWDXR(.ORCPLX,ORIFN)
SET ORCPLX=+$GET(ORCPLX)
+52 SET (CNT,S1)=0
FOR
SET S1=$ORDER(OCHKS(S1))
if 'S1
QUIT
SET CNT=CNT+1
SET ORFLDS("ORCHECK",$PIECE(OCHKS(S1),U),$PIECE(OCHKS(S1),U,3),CNT)=$PIECE(OCHKS(S1),U,2,99)
+53 IF CNT>0
SET ORFLDS("ORCHECK")=CNT
+54 DO RENEW^ORWDXR(.LIST,ORIFN,DFN,ORPROV,ORL,.ORFLDS,ORCPLX,0)
SET ORRESULT=1
+55 SET NEWIFN=$PIECE(^OR(100,ORIFN,3),U,6)
+56 SET $PIECE(^OR(100,NEWIFN,8,1,0),U,13)=ORUSR
+57 DO UNSIGNED(NEWIFN)
+58 DO KILUNSNO^ORWORB(.Y,DFN)
+59 DO KILEXMED^ORWORB(.Y,DFN)
UNO DO UNLKORD^ORWDX(.OK,ORIFN)
UNLOCK DO UNLOCK^ORWDX(.OK,DFN)
+1 ;
END ;*249 Modify END.
+1 ;Merge Message Arrays into ^TMP( for VEXRX, add header if needed.
+2 NEW I,J,RXELN,DRGLN,DSPNMLN,SPACE
+3 SET SPACE=$JUSTIFY(" ",40)
+4 SET RXELN=$$GET1^DID(52,.01,"","FIELD LENGTH")
SET DRGLN=$$GET1^DID(52,6,"","FIELD LENGTH")
SET DSPNMLN=$$GET1^DID(2,.01,"","FIELD LENGTH")
+5 IF $DATA(EMSG)
Begin DoDot:1
+6 SET J=$ORDER(^TMP($JOB,"ORAREN E",""),-1)+1
+7 IF J<2
Begin DoDot:2
+8 SET ^TMP($JOB,"ORAREN E",J,0)="Renewal Requests Not Sent to Provider"
SET J=J+1
+9 SET ^TMP($JOB,"ORAREN E",J,0)=" "
SET J=J+1
+10 SET ^TMP($JOB,"ORAREN E",J,0)=$EXTRACT("PATIENT"_SPACE,0,DSPNMLN)_" "_$EXTRACT("RX#"_SPACE,0,RXELN)_" "_$EXTRACT("DRUG"_SPACE,0,DRGLN)
SET J=J+1
+11 SET ^TMP($JOB,"ORAREN E",J,0)=" PROBLEM"
SET J=J+1
+12 SET ^TMP($JOB,"ORAREN E",J,0)="=============================================================================="
SET J=J+1
+13 SET ^TMP($JOB,"ORAREN E",J,0)=" "
SET J=J+1
End DoDot:2
+14 FOR I=0:0
SET I=$ORDER(EMSG(I))
if 'I
QUIT
SET ^TMP($JOB,"ORAREN E",J,0)=EMSG(I)
SET J=J+1
End DoDot:1
+15 IF $DATA(INMSG)
Begin DoDot:1
+16 SET J=$ORDER(^TMP($JOB,"ORAREN OC",""),-1)+1
+17 IF J<2
Begin DoDot:2
+18 SET ^TMP($JOB,"ORAREN OC",J,0)="Renewal Requests with Order Checks"
SET J=J+1
+19 SET ^TMP($JOB,"ORAREN OC",J,0)=" "
SET J=J+1
+20 SET ^TMP($JOB,"ORAREN OC",J,0)=$EXTRACT("PATIENT"_SPACE,0,DSPNMLN)_" "_$EXTRACT("RX#"_SPACE,0,RXELN)_" "_$EXTRACT("DRUG"_SPACE,0,DRGLN)
SET J=J+1
+21 SET ^TMP($JOB,"ORAREN OC",J,0)="=============================================================================="
SET J=J+1
+22 SET ^TMP($JOB,"ORAREN OC",J,0)=" "
SET J=J+1
End DoDot:2
+23 ;OR*3.0*540: Break up order check lines greater than 500 characters
+24 FOR I=0:0
SET I=$ORDER(INMSG(I))
if 'I
QUIT
Begin DoDot:2
+25 IF $LENGTH(INMSG(I))<500
SET ^TMP($JOB,"ORAREN OC",J,0)=INMSG(I)
SET J=J+1
QUIT
+26 DO SEG
End DoDot:2
End DoDot:1
+27 DO CLRALLGY^ORWDXC("",DFN)
+28 QUIT
+29 ;
SEG ;break up lines longer than 500 characters
+1 NEW ORLEN,OREND,ORSQ,ORX1,ORX2
+2 SET ORLEN=$LENGTH(INMSG(I))
SET OREND=ORLEN/500
+3 ;Round number of iterations to next whole number.
+4 SET OREND=$SELECT($PIECE(OREND,".",2)>0:$PIECE(OREND,".")+1,1:$PIECE(OREND,"."))
+5 FOR ORSQ=1:1:OREND
Begin DoDot:1
+6 SET ORX1=(ORSQ-1*500)+1
+7 SET ORX2=ORSQ*500
+8 SET ^TMP($JOB,"ORAREN OC",J,0)=$EXTRACT(INMSG(I),ORX1,ORX2)
+9 SET J=J+1
End DoDot:1
+10 QUIT
+11 ;
AE(MSARY,RX,DFN,TEXT,PDET) ;*349
+1 ;Input: MSARY - Output aray
+2 ; RX - Internal RX#
+3 ; DFN - Internal Patient DFN
+4 ;Output: MSARY will be appended with a line pertaining to the input.
+5 ;
+6 NEW I,S1,SPACE,CNT,RXE,DRG,PNM,SSN,SSID,SPACE
SET SPACE=$JUSTIFY(" ",40)
SET CNT=1
+7 NEW RXELN,DRGLN,DSPNMLN
+8 SET RXE=$$GET1^DIQ(52,RX,.01,"E")
SET DRG=$$GET1^DIQ(52,RX,6,"E")
SET PNM=$$GET1^DIQ(2,DFN,.01,"E")
SET SSN=+$$GET1^DIQ(2,DFN,.09,"E")
+9 SET RXELN=$$GET1^DID(52,.01,"","FIELD LENGTH")
SET DRGLN=$$GET1^DID(52,6,"","FIELD LENGTH")
SET DSPNMLN=$$GET1^DID(2,.01,"","FIELD LENGTH")
+10 SET SSID="("_$EXTRACT(PNM,1)_$EXTRACT(SSN,$LENGTH(SSN)-3,$LENGTH(SSN))_")"
+11 ;Have to truncate Patient name if it is too long.
SET DSPNM=$EXTRACT(PNM,1,DSPNMLN-$LENGTH(" "_SSID))_" "_SSID
+12 FOR I="DSPNM","RXE","DRG"
SET MSARY(CNT)=$GET(MSARY(CNT))_$EXTRACT(@I_SPACE,1,@(I_"LN"))_" "
+13 SET CNT=CNT+1
+14 SET MSARY(CNT)=$EXTRACT(SPACE,0,4)_TEXT
SET CNT=CNT+1
+15 IF $DATA(PDET)
IF $ORDER(PDET(0))=""
SET MSARY(CNT)=$EXTRACT(SPACE,0,4)_PDET
SET CNT=CNT+1
QUIT
+16 IF $DATA(PDET)
SET S1=0
FOR
SET S1=$ORDER(PDET(S1))
if 'S1
QUIT
SET MSARY(CNT)=$EXTRACT(SPACE,0,4)_PDET(S1)
SET CNT=CNT+1
+17 QUIT
+18 ;
INFO(INARY,RX,DFN,MSG) ;file informational items in mail message ;*349
+1 ;Input: INARY - Output aray
+2 ; RX - Internal RX#
+3 ; DFN - Internal Patient DFN
+4 ; MSG - Message Array
+5 ;Output: INARY will be appended with a line pertaining to the input.
+6 ;
+7 NEW I,SPACE,CNT,RXE,DRG,PNM,SSN,SSID,DSPNM,SPACE,S1
SET SPACE=$JUSTIFY(" ",40)
SET CNT=1
+8 NEW RXELN,DRGLN,DSPNMLN
+9 IF $DATA(INARY)
SET CNT=$ORDER(INARY(""),-1)
+10 IF '$DATA(INARY)
Begin DoDot:1
+11 SET RXE=$$GET1^DIQ(52,RX,.01,"E")
SET DRG=$$GET1^DIQ(52,RX,6,"E")
SET PNM=$$GET1^DIQ(2,DFN,.01,"E")
SET SSN=+$$GET1^DIQ(2,DFN,.09,"E")
+12 SET RXELN=$$GET1^DID(52,.01,"","FIELD LENGTH")
SET DRGLN=$$GET1^DID(52,6,"","FIELD LENGTH")
SET DSPNMLN=$$GET1^DID(2,.01,"","FIELD LENGTH")
+13 SET SSID="("_$EXTRACT(PNM,1)_$EXTRACT(SSN,$LENGTH(SSN)-3,$LENGTH(SSN))_")"
+14 ;Have to truncate Patient name if it is too long.
SET DSPNM=$EXTRACT(PNM,1,DSPNMLN-$LENGTH(" "_SSID))_" "_SSID
+15 FOR I="DSPNM","RXE","DRG"
SET INARY(CNT)=$GET(INARY(CNT))_$EXTRACT(@I_SPACE,0,@(I_"LN"))_" "
End DoDot:1
+16 SET CNT=CNT+1
SET INARY(CNT)=" "
SET CNT=CNT+1
SET S1=0
+17 FOR
SET S1=$ORDER(MSG(S1))
if 'S1
QUIT
Begin DoDot:1
+18 IF $LENGTH(MSG(S1),U)>2
SET INARY(CNT)=$PIECE(MSG(S1),U,4,99)
SET CNT=CNT+1
QUIT
+19 SET INARY(CNT)=$EXTRACT(SPACE,0,5)_MSG(S1)
SET CNT=CNT+1
End DoDot:1
SET INARY(CNT)=" "
SET CNT=CNT+1
+20 QUIT
UNSIGNED(UIFN) ;queue unsigned order alert
+1 NEW ORVP,ORIFN,ORNP,A
+2 if $GET(UIFN)=""
QUIT
SET A=$GET(^OR(100,UIFN,0))
SET ORVP=$PIECE(A,U,2)
SET ORNP=$PIECE(A,U,4)
SET ORIFN=UIFN_";1"
+3 DO NOTIF^ORCSIGN
+4 QUIT
