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

ORAREN.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. ;The purpose of this API is to process a request to renew an
  1. ;Outpatient Prescription
  1. ;
  1. ; DBIA 2790 - ACTVSURO^XQALSURO
  1. ; DBIA 2343 - ACTIVE^XUSER
  1. ; DBIA 2848 - GETALL^SCAPMCA
  1. ; DBIA 2263 - GET^XPAR
  1. ;
  1. Q
  1. RENEW(ORRESULT,DFN,RX,PROVP,RENEWF) ;
  1. ;Input - DFN of the patient
  1. ; RX to be renewed
  1. ;
  1. ; One assumption is made for now and that is that the TMP globals and the message counters are
  1. ; initialized by the calling routine. Not a perfect scenario, but in order to batch the mail
  1. ; messages that is what was done.
  1. ;*349 Added passing to build the message for variable safety. And mail reformat.
  1. N X,OK,ORY,ORPKG,ORITM,ORIFN,PSOSTAT,A,PDET,ORFLDS,DRUG,DISPLAY,FAIL,LIST,OCHKS,OCO,OCLIST,ORCPLX,ORINFO,ORPVSTS
  1. N ORL,ORPROV,PCP,PCPN,RNWFLDS,Y,ORUSR,NEWIFN,PNM,RXE,EMSG,INMSG,ORPROVNM ;*349
  1. K ^TMP("SC",$J) S RENEWF=$G(RENEWF)
  1. I $G(PROVP)="" S PROVP="A"
  1. 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
  1. D EN^PSOORDER(DFN,RX)
  1. S DRUG=$P($G(^TMP("PSOR",$J,RX,"DRUG",0)),U,2)
  1. S:DRUG="" DRUG=$P($P($G(^TMP("PSOR",$J,RX,"DRUG",0)),U),";",2)
  1. 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
  1. D LOCK^ORWDX(.OK,DFN) I 'OK D AE(.EMSG,RX,DFN,"Chart Lock Failed") S ORRESULT=0 G END
  1. 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
  1. I RENEWF="N" D G UNLOCK
  1. .D AE(.EMSG,RX,DFN,"Drug not renewable")
  1. .D EN^ORB3(73,DFN,ORIFN,"","Non-Renewable RX Request for "_DRUG,"NEW;"_ORIFN)
  1. .S ORRESULT=0
  1. D LOCKORD^ORWDX(.OK,ORIFN) I 'OK D AE(.EMSG,RX,DFN,"Order Lock Failed") S ORRESULT=0 G UNLOCK
  1. S A=$G(^OR(100,ORIFN,0)) I A="" D AE(.EMSG,RX,DFN,"Order missing from ORDERS file") S ORRESULT=0 G UNO
  1. S ORPROV=+$P(A,U,4),ORL=+$P(A,U,10)
  1. ;*349 Add Provider name, check valid surogate
  1. S ORPROVNM=$$GET1^DIQ(200,ORPROV,.01,"E"),ORPVSTS=$$ACTIVE^XUSER(ORPROV)
  1. I ORPROVNM]"" S ORPROVNM="("_ORPROVNM_")"
  1. 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
  1. S PCPN=$$GETALL^SCAPMCA(DFN),PCP=+$G(^TMP("SC",$J,DFN,"PCPR",1))
  1. I PROVP="P",ORPROV'=PCP D AE(.EMSG,RX,DFN,"Ordering Provider "_ORPROVNM_" not Primary Care") S ORRESULT=3 G UNO
  1. 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
  1. D VALID^ORWDXA(.ORY,ORIFN,"RN",ORPROV)
  1. I $G(ORY)]"" D G UNO
  1. .D AE(.EMSG,RX,DFN,"Invalid Action - details below",.ORY)
  1. .D:$$UP^XLFSTR(ORY)["NON-RENEWABLE" EN^ORB3(73,DFN,ORIFN,"","Non-Renewable RX Request for "_DRUG,"NEW;"_ORIFN)
  1. .S ORRESULT=0
  1. D GETPKG^ORWDXR(.ORPKG,ORIFN) I '$D(ORPKG) D AE(.EMSG,RX,DFN,"Invalid Order Number") S ORRESULT=0 G UNO
  1. I ORPKG'="PSO" D AE(.EMSG,RX,DFN,"Problem with package in ORDERS file") S ORRESULT=0 G UNO
  1. D GTORITM^ORWDXR(.ORITM,ORIFN)
  1. D FAILDEA^ORWDPS1(.FAIL,ORITM,ORPROV,"O") I FAIL D AE(.EMSG,RX,DFN,"Failed DEA Check") S ORRESULT=0 G UNO
  1. ;*349 Maintain AUDIO RENEWAL USER on pharmacy side.
  1. D RNWFLDS^ORWDXR(.RNWFLDS,ORIFN) S ORFLDS(1)=RNWFLDS(0),ORFLDS("ORDUZ")=ORUSR
  1. D CHKGRP^ORWDPS2(.DISPLAY,ORIFN) I DISPLAY'=2 D AE(.EMSG,RX,DFN,"Package Problem on Order") S ORRESULT=0 G UNO
  1. D ON^ORWDXC(.OCO)
  1. D DISPLAY^ORWDXC(.OCLIST,DFN,ORPKG) I $D(OCLIST) D INFO(.INMSG,RX,DFN,.OCLIST)
  1. D OXDATA^ORWDXR01(.ORINFO,ORIFN)
  1. S ORINFO(1)=ORINFO
  1. D ACCEPT^ORWDXC(.OCHKS,DFN,"PSO","",ORL,.ORINFO,ORIFN,1)
  1. I $D(OCHKS) D INFO(.INMSG,RX,DFN,.OCHKS)
  1. D ISCPLX^ORWDXR(.ORCPLX,ORIFN) S ORCPLX=+$G(ORCPLX)
  1. 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)
  1. I CNT>0 S ORFLDS("ORCHECK")=CNT
  1. D RENEW^ORWDXR(.LIST,ORIFN,DFN,ORPROV,ORL,.ORFLDS,ORCPLX,0) S ORRESULT=1
  1. S NEWIFN=$P(^OR(100,ORIFN,3),U,6)
  1. S $P(^OR(100,NEWIFN,8,1,0),U,13)=ORUSR
  1. D UNSIGNED(NEWIFN)
  1. D KILUNSNO^ORWORB(.Y,DFN)
  1. D KILEXMED^ORWORB(.Y,DFN)
  1. UNO D UNLKORD^ORWDX(.OK,ORIFN)
  1. UNLOCK D UNLOCK^ORWDX(.OK,DFN)
  1. ;
  1. END ;*249 Modify END.
  1. ;Merge Message Arrays into ^TMP( for VEXRX, add header if needed.
  1. N I,J,RXELN,DRGLN,DSPNMLN,SPACE
  1. S SPACE=$J(" ",40)
  1. S RXELN=$$GET1^DID(52,.01,"","FIELD LENGTH"),DRGLN=$$GET1^DID(52,6,"","FIELD LENGTH"),DSPNMLN=$$GET1^DID(2,.01,"","FIELD LENGTH")
  1. I $D(EMSG) D
  1. . S J=$O(^TMP($J,"ORAREN E",""),-1)+1
  1. . I J<2 D
  1. . . S ^TMP($J,"ORAREN E",J,0)="Renewal Requests Not Sent to Provider",J=J+1
  1. . . S ^TMP($J,"ORAREN E",J,0)=" ",J=J+1
  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
  1. . . S ^TMP($J,"ORAREN E",J,0)=" PROBLEM",J=J+1
  1. . . S ^TMP($J,"ORAREN E",J,0)="==============================================================================",J=J+1
  1. . . S ^TMP($J,"ORAREN E",J,0)=" ",J=J+1
  1. . F I=0:0 S I=$O(EMSG(I)) Q:'I S ^TMP($J,"ORAREN E",J,0)=EMSG(I),J=J+1
  1. I $D(INMSG) D
  1. . S J=$O(^TMP($J,"ORAREN OC",""),-1)+1
  1. . I J<2 D
  1. . . S ^TMP($J,"ORAREN OC",J,0)="Renewal Requests with Order Checks",J=J+1
  1. . . S ^TMP($J,"ORAREN OC",J,0)=" ",J=J+1
  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
  1. . . S ^TMP($J,"ORAREN OC",J,0)="==============================================================================",J=J+1
  1. . . S ^TMP($J,"ORAREN OC",J,0)=" ",J=J+1
  1. . ;OR*3.0*540: Break up order check lines greater than 500 characters
  1. . F I=0:0 S I=$O(INMSG(I)) Q:'I D
  1. . . I $L(INMSG(I))<500 S ^TMP($J,"ORAREN OC",J,0)=INMSG(I),J=J+1 Q
  1. . . D SEG
  1. D CLRALLGY^ORWDXC("",DFN)
  1. Q
  1. ;
  1. SEG ;break up lines longer than 500 characters
  1. N ORLEN,OREND,ORSQ,ORX1,ORX2
  1. S ORLEN=$L(INMSG(I)),OREND=ORLEN/500
  1. ;Round number of iterations to next whole number.
  1. S OREND=$S($P(OREND,".",2)>0:$P(OREND,".")+1,1:$P(OREND,"."))
  1. F ORSQ=1:1:OREND D
  1. . S ORX1=(ORSQ-1*500)+1
  1. . S ORX2=ORSQ*500
  1. . S ^TMP($J,"ORAREN OC",J,0)=$E(INMSG(I),ORX1,ORX2)
  1. . S J=J+1
  1. Q
  1. ;
  1. AE(MSARY,RX,DFN,TEXT,PDET) ;*349
  1. ;Input: MSARY - Output aray
  1. ; RX - Internal RX#
  1. ; DFN - Internal Patient DFN
  1. ;Output: MSARY will be appended with a line pertaining to the input.
  1. ;
  1. N I,S1,SPACE,CNT,RXE,DRG,PNM,SSN,SSID,SPACE S SPACE=$J(" ",40),CNT=1
  1. N RXELN,DRGLN,DSPNMLN
  1. 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")
  1. S RXELN=$$GET1^DID(52,.01,"","FIELD LENGTH"),DRGLN=$$GET1^DID(52,6,"","FIELD LENGTH"),DSPNMLN=$$GET1^DID(2,.01,"","FIELD LENGTH")
  1. S SSID="("_$E(PNM,1)_$E(SSN,$L(SSN)-3,$L(SSN))_")"
  1. S DSPNM=$E(PNM,1,DSPNMLN-$L(" "_SSID))_" "_SSID ;Have to truncate Patient name if it is too long.
  1. F I="DSPNM","RXE","DRG" S MSARY(CNT)=$G(MSARY(CNT))_$E(@I_SPACE,1,@(I_"LN"))_" "
  1. S CNT=CNT+1
  1. S MSARY(CNT)=$E(SPACE,0,4)_TEXT,CNT=CNT+1
  1. I $D(PDET),$O(PDET(0))="" S MSARY(CNT)=$E(SPACE,0,4)_PDET,CNT=CNT+1 Q
  1. 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
  1. Q
  1. ;
  1. INFO(INARY,RX,DFN,MSG) ;file informational items in mail message ;*349
  1. ;Input: INARY - Output aray
  1. ; RX - Internal RX#
  1. ; DFN - Internal Patient DFN
  1. ; MSG - Message Array
  1. ;Output: INARY will be appended with a line pertaining to the input.
  1. ;
  1. N I,SPACE,CNT,RXE,DRG,PNM,SSN,SSID,DSPNM,SPACE,S1 S SPACE=$J(" ",40),CNT=1
  1. N RXELN,DRGLN,DSPNMLN
  1. I $D(INARY) S CNT=$O(INARY(""),-1)
  1. I '$D(INARY) D
  1. . 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")
  1. . S RXELN=$$GET1^DID(52,.01,"","FIELD LENGTH"),DRGLN=$$GET1^DID(52,6,"","FIELD LENGTH"),DSPNMLN=$$GET1^DID(2,.01,"","FIELD LENGTH")
  1. . S SSID="("_$E(PNM,1)_$E(SSN,$L(SSN)-3,$L(SSN))_")"
  1. . S DSPNM=$E(PNM,1,DSPNMLN-$L(" "_SSID))_" "_SSID ;Have to truncate Patient name if it is too long.
  1. . F I="DSPNM","RXE","DRG" S INARY(CNT)=$G(INARY(CNT))_$E(@I_SPACE,0,@(I_"LN"))_" "
  1. S CNT=CNT+1,INARY(CNT)=" ",CNT=CNT+1,S1=0
  1. F S S1=$O(MSG(S1)) Q:'S1 D S INARY(CNT)=" ",CNT=CNT+1
  1. . I $L(MSG(S1),U)>2 S INARY(CNT)=$P(MSG(S1),U,4,99),CNT=CNT+1 Q
  1. . S INARY(CNT)=$E(SPACE,0,5)_MSG(S1),CNT=CNT+1
  1. Q
  1. UNSIGNED(UIFN) ;queue unsigned order alert
  1. N ORVP,ORIFN,ORNP,A
  1. Q:$G(UIFN)="" S A=$G(^OR(100,UIFN,0)),ORVP=$P(A,U,2),ORNP=$P(A,U,4),ORIFN=UIFN_";1"
  1. D NOTIF^ORCSIGN
  1. Q