PSOPXRMI ; ISC/MFR - Build Reminders Indexes for PSRX ;14-Jul-2015 14:26;DU
;;7.0;OUTPATIENT PHARMACY;**118,1015,1019**;DEC 1997;Build 4
;External reference to PXRMSXRM is supported by DBIA 4113
;External reference to File ^PXRMINDX( supported by DBIA 4114
;Modified - IHS/MSC/nMGH - 10/03/2012 - patch 1015 to just quit if pt or drug not there and to
;only send error on misisng days supply if its less than 1 year old
;IHS/MSC/MGH patch 1015 quit without error message if RX is over 1 year old
;IHS/MSC/MGH patch 1019 fix for index rebuild and erx meds
;
PSRX ;Build the index for the Prescription File.
N DA,DA1,DAS,DATE,DSUP,DFN,DRUG,END,ENTRIES,GLOBAL,IDEN,IND,INS
N NE,NERROR,RDATE,SDATE,IDATE,START,TENP,TEXT,YR,X,X1,X2,FDATE
;Don't leave any old stuff around.
K ^PXRMINDX(52)
S GLOBAL=$$GET1^DID(52,"","","GLOBAL NAME")
S X1=$$NOW^XLFDT,X2=-365 D C^%DTC S YR=X ;Patch 1015
S ENTRIES=$P(^PSRX(0),U,4)
S TENP=ENTRIES/10
S TENP=+$P(TENP,".",1)
I TENP<1 S TENP=1
D BMES^XPDUTL("Building indexes for PRESCRIPTION FILE")
S TEXT="There are "_ENTRIES_" entries to process."
D MES^XPDUTL(TEXT)
S START=$H
S (DA1,IND,NE,NERROR)=0
F S DA1=+$O(^PSRX(DA1)) Q:DA1=0 D
. S IND=IND+1
. I IND#TENP=0 D
.. S TEXT="Processing entry "_IND
.. D MES^XPDUTL(TEXT)
. I IND#10000=0 W "."
. S TEMP=$G(^PSRX(DA1,0))
. S DFN=$P(TEMP,U,2)
. Q:DFN="" ;Patch 1015
. ;I DFN="" D Q
. ;. S IDEN=DA1_" missing DFN"
. ;. D ADDERROR^PXRMSXRM(GLOBAL,IDEN,.NERROR)
. S DRUG=$P(TEMP,U,6)
. Q:DRUG="" ;Patch 1015
. ;I DRUG="" D Q
. ;. S IDEN=DA1_" missing drug"
. ;. D ADDERROR^PXRMSXRM(GLOBAL,IDEN,.NERROR) Q
. S IDATE=$P(TEMP,U,13) ;Patch 1015
. S DSUP=$P(TEMP,U,8)
. I DSUP="" D Q
..I IDATE>YR D ;Patch 1015
... S IDEN=DA1_" missing days supply"
... D ADDERROR^PXRMSXRM(GLOBAL,IDEN,.NERROR)
. S RDATE=+$P($G(^PSRX(DA1,2)),U,13)
. S FDATE=+$P($G(^PSRX(DA1,2)),U,2) ;Patch 1019
. I RDATE=0&($P($G(^PSRX(DA1,999999921)),U,3)'="") S RDATE=FDATE ;Patch 1019
. I RDATE>0 D
.. S SDATE=+$$FMADD^XLFDT(RDATE,DSUP)
.. S DAS=DA1_";2"
.. S ^PXRMINDX(52,"IP",DRUG,DFN,RDATE,SDATE,DAS)=""
.. S ^PXRMINDX(52,"PI",DFN,DRUG,RDATE,SDATE,DAS)=""
.. S NE=NE+1
.;Process the refill mutiple.
. S DA=0
. F S DA=+$O(^PSRX(DA1,1,DA)) Q:DA=0 D
.. S TEMP=$G(^PSRX(DA1,1,DA,0))
.. S DSUP=+$P(TEMP,U,10)
.. S RDATE=+$P(TEMP,U,18)
.. I RDATE>0 D
... S SDATE=+$$FMADD^XLFDT(RDATE,DSUP)
... S DAS=DA1_";1;"_DA_";0"
... S ^PXRMINDX(52,"IP",DRUG,DFN,RDATE,SDATE,DAS)=""
... S ^PXRMINDX(52,"PI",DFN,DRUG,RDATE,SDATE,DAS)=""
... S NE=NE+1
.;Process the partial fill multiple.
. S DA=0
. F S DA=+$O(^PSRX(DA1,"P",DA)) Q:DA=0 D
.. S TEMP=$G(^PSRX(DA1,"P",DA,0))
.. S DSUP=+$P(TEMP,U,10)
.. S RDATE=+$P(TEMP,U,19)
.. I RDATE>0 D
... S SDATE=+$$FMADD^XLFDT(RDATE,DSUP)
... S DAS=DA1_";P;"_DA_";0"
... S ^PXRMINDX(52,"IP",DRUG,DFN,RDATE,SDATE,DAS)=""
... S ^PXRMINDX(52,"PI",DFN,DRUG,RDATE,SDATE,DAS)=""
... S NE=NE+1
S END=$H
S TEXT=NE_" PRESCRIPTION results indexed."
D MES^XPDUTL(TEXT)
S TEXT=NERROR_" errors were encountered."
D MES^XPDUTL(TEXT)
D DETIME^PXRMSXRM(START,END)
;If there were errors send a message.
I NERROR>0 D ERRMSG^PXRMSXRM(NERROR,GLOBAL)
;Send a MailMan message with the results.
D COMMSG^PXRMSXRM(GLOBAL,START,END,NE,NERROR)
S ^PXRMINDX(52,"GLOBAL NAME")=GLOBAL
S ^PXRMINDX(52,"BUILT BY")=DUZ
S ^PXRMINDX(52,"DATE BUILT")=$$NOW^XLFDT
Q
;
PSOPXRMI ; ISC/MFR - Build Reminders Indexes for PSRX ;14-Jul-2015 14:26;DU
+1 ;;7.0;OUTPATIENT PHARMACY;**118,1015,1019**;DEC 1997;Build 4
+2 ;External reference to PXRMSXRM is supported by DBIA 4113
+3 ;External reference to File ^PXRMINDX( supported by DBIA 4114
+4 ;Modified - IHS/MSC/nMGH - 10/03/2012 - patch 1015 to just quit if pt or drug not there and to
+5 ;only send error on misisng days supply if its less than 1 year old
+6 ;IHS/MSC/MGH patch 1015 quit without error message if RX is over 1 year old
+7 ;IHS/MSC/MGH patch 1019 fix for index rebuild and erx meds
+8 ;
PSRX ;Build the index for the Prescription File.
+1 NEW DA,DA1,DAS,DATE,DSUP,DFN,DRUG,END,ENTRIES,GLOBAL,IDEN,IND,INS
+2 NEW NE,NERROR,RDATE,SDATE,IDATE,START,TENP,TEXT,YR,X,X1,X2,FDATE
+3 ;Don't leave any old stuff around.
+4 KILL ^PXRMINDX(52)
+5 SET GLOBAL=$$GET1^DID(52,"","","GLOBAL NAME")
+6 ;Patch 1015
SET X1=$$NOW^XLFDT
SET X2=-365
DO C^%DTC
SET YR=X
+7 SET ENTRIES=$PIECE(^PSRX(0),U,4)
+8 SET TENP=ENTRIES/10
+9 SET TENP=+$PIECE(TENP,".",1)
+10 IF TENP<1
SET TENP=1
+11 DO BMES^XPDUTL("Building indexes for PRESCRIPTION FILE")
+12 SET TEXT="There are "_ENTRIES_" entries to process."
+13 DO MES^XPDUTL(TEXT)
+14 SET START=$HOROLOG
+15 SET (DA1,IND,NE,NERROR)=0
+16 FOR
SET DA1=+$ORDER(^PSRX(DA1))
IF DA1=0
QUIT
Begin DoDot:1
+17 SET IND=IND+1
+18 IF IND#TENP=0
Begin DoDot:2
+19 SET TEXT="Processing entry "_IND
+20 DO MES^XPDUTL(TEXT)
End DoDot:2
+21 IF IND#10000=0
WRITE "."
+22 SET TEMP=$GET(^PSRX(DA1,0))
+23 SET DFN=$PIECE(TEMP,U,2)
+24 ;Patch 1015
IF DFN=""
QUIT
+25 ;I DFN="" D Q
+26 ;. S IDEN=DA1_" missing DFN"
+27 ;. D ADDERROR^PXRMSXRM(GLOBAL,IDEN,.NERROR)
+28 SET DRUG=$PIECE(TEMP,U,6)
+29 ;Patch 1015
IF DRUG=""
QUIT
+30 ;I DRUG="" D Q
+31 ;. S IDEN=DA1_" missing drug"
+32 ;. D ADDERROR^PXRMSXRM(GLOBAL,IDEN,.NERROR) Q
+33 ;Patch 1015
SET IDATE=$PIECE(TEMP,U,13)
+34 SET DSUP=$PIECE(TEMP,U,8)
+35 IF DSUP=""
Begin DoDot:2
+36 ;Patch 1015
IF IDATE>YR
Begin DoDot:3
+37 SET IDEN=DA1_" missing days supply"
+38 DO ADDERROR^PXRMSXRM(GLOBAL,IDEN,.NERROR)
End DoDot:3
End DoDot:2
QUIT
+39 SET RDATE=+$PIECE($GET(^PSRX(DA1,2)),U,13)
+40 ;Patch 1019
SET FDATE=+$PIECE($GET(^PSRX(DA1,2)),U,2)
+41 ;Patch 1019
IF RDATE=0&($PIECE($GET(^PSRX(DA1,999999921)),U,3)'="")
SET RDATE=FDATE
+42 IF RDATE>0
Begin DoDot:2
+43 SET SDATE=+$$FMADD^XLFDT(RDATE,DSUP)
+44 SET DAS=DA1_";2"
+45 SET ^PXRMINDX(52,"IP",DRUG,DFN,RDATE,SDATE,DAS)=""
+46 SET ^PXRMINDX(52,"PI",DFN,DRUG,RDATE,SDATE,DAS)=""
+47 SET NE=NE+1
End DoDot:2
+48 ;Process the refill mutiple.
+49 SET DA=0
+50 FOR
SET DA=+$ORDER(^PSRX(DA1,1,DA))
IF DA=0
QUIT
Begin DoDot:2
+51 SET TEMP=$GET(^PSRX(DA1,1,DA,0))
+52 SET DSUP=+$PIECE(TEMP,U,10)
+53 SET RDATE=+$PIECE(TEMP,U,18)
+54 IF RDATE>0
Begin DoDot:3
+55 SET SDATE=+$$FMADD^XLFDT(RDATE,DSUP)
+56 SET DAS=DA1_";1;"_DA_";0"
+57 SET ^PXRMINDX(52,"IP",DRUG,DFN,RDATE,SDATE,DAS)=""
+58 SET ^PXRMINDX(52,"PI",DFN,DRUG,RDATE,SDATE,DAS)=""
+59 SET NE=NE+1
End DoDot:3
End DoDot:2
+60 ;Process the partial fill multiple.
+61 SET DA=0
+62 FOR
SET DA=+$ORDER(^PSRX(DA1,"P",DA))
IF DA=0
QUIT
Begin DoDot:2
+63 SET TEMP=$GET(^PSRX(DA1,"P",DA,0))
+64 SET DSUP=+$PIECE(TEMP,U,10)
+65 SET RDATE=+$PIECE(TEMP,U,19)
+66 IF RDATE>0
Begin DoDot:3
+67 SET SDATE=+$$FMADD^XLFDT(RDATE,DSUP)
+68 SET DAS=DA1_";P;"_DA_";0"
+69 SET ^PXRMINDX(52,"IP",DRUG,DFN,RDATE,SDATE,DAS)=""
+70 SET ^PXRMINDX(52,"PI",DFN,DRUG,RDATE,SDATE,DAS)=""
+71 SET NE=NE+1
End DoDot:3
End DoDot:2
End DoDot:1
+72 SET END=$HOROLOG
+73 SET TEXT=NE_" PRESCRIPTION results indexed."
+74 DO MES^XPDUTL(TEXT)
+75 SET TEXT=NERROR_" errors were encountered."
+76 DO MES^XPDUTL(TEXT)
+77 DO DETIME^PXRMSXRM(START,END)
+78 ;If there were errors send a message.
+79 IF NERROR>0
DO ERRMSG^PXRMSXRM(NERROR,GLOBAL)
+80 ;Send a MailMan message with the results.
+81 DO COMMSG^PXRMSXRM(GLOBAL,START,END,NE,NERROR)
+82 SET ^PXRMINDX(52,"GLOBAL NAME")=GLOBAL
+83 SET ^PXRMINDX(52,"BUILT BY")=DUZ
+84 SET ^PXRMINDX(52,"DATE BUILT")=$$NOW^XLFDT
+85 QUIT
+86 ;
