- 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 Feb 18, 2025@23:53:47 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