PSOPXRMI ; ISC/MFR - Build Reminders Indexes for PSRX ;06/18/2003
;;7.0;OUTPATIENT PHARMACY;**118**;DEC 1997
;External reference to PXRMSXRM is supported by DBIA 4113
;External reference to File ^PXRMINDX( supported by DBIA 4114
;
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,START,TENP,TEXT
;Don't leave any old stuff around.
K ^PXRMINDX(52)
S GLOBAL=$$GET1^DID(52,"","","GLOBAL NAME")
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)
. I DFN="" D Q
.. S IDEN=DA1_" missing DFN"
.. D ADDERROR^PXRMSXRM(GLOBAL,IDEN,.NERROR)
. S DRUG=$P(TEMP,U,6)
. I DRUG="" D Q
.. S IDEN=DA1_" missing drug"
.. D ADDERROR^PXRMSXRM(GLOBAL,IDEN,.NERROR) Q
. S DSUP=$P(TEMP,U,8)
. I DSUP="" D Q
.. S IDEN=DA1_" missing days supply"
.. D ADDERROR^PXRMSXRM(GLOBAL,IDEN,.NERROR)
. S RDATE=+$P($G(^PSRX(DA1,2)),U,13)
. 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
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HPSOPXRMI 2819 printed Dec 13, 2024@02:33:13 Page 2
PSOPXRMI ; ISC/MFR - Build Reminders Indexes for PSRX ;06/18/2003
+1 ;;7.0;OUTPATIENT PHARMACY;**118**;DEC 1997
+2 ;External reference to PXRMSXRM is supported by DBIA 4113
+3 ;External reference to File ^PXRMINDX( supported by DBIA 4114
+4 ;
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,START,TENP,TEXT
+3 ;Don't leave any old stuff around.
+4 KILL ^PXRMINDX(52)
+5 SET GLOBAL=$$GET1^DID(52,"","","GLOBAL NAME")
+6 SET ENTRIES=$PIECE(^PSRX(0),U,4)
+7 SET TENP=ENTRIES/10
+8 SET TENP=+$PIECE(TENP,".",1)
+9 IF TENP<1
SET TENP=1
+10 DO BMES^XPDUTL("Building indexes for PRESCRIPTION FILE")
+11 SET TEXT="There are "_ENTRIES_" entries to process."
+12 DO MES^XPDUTL(TEXT)
+13 SET START=$HOROLOG
+14 SET (DA1,IND,NE,NERROR)=0
+15 FOR
SET DA1=+$ORDER(^PSRX(DA1))
if DA1=0
QUIT
Begin DoDot:1
+16 SET IND=IND+1
+17 IF IND#TENP=0
Begin DoDot:2
+18 SET TEXT="Processing entry "_IND
+19 DO MES^XPDUTL(TEXT)
End DoDot:2
+20 IF IND#10000=0
WRITE "."
+21 SET TEMP=$GET(^PSRX(DA1,0))
+22 SET DFN=$PIECE(TEMP,U,2)
+23 IF DFN=""
Begin DoDot:2
+24 SET IDEN=DA1_" missing DFN"
+25 DO ADDERROR^PXRMSXRM(GLOBAL,IDEN,.NERROR)
End DoDot:2
QUIT
+26 SET DRUG=$PIECE(TEMP,U,6)
+27 IF DRUG=""
Begin DoDot:2
+28 SET IDEN=DA1_" missing drug"
+29 DO ADDERROR^PXRMSXRM(GLOBAL,IDEN,.NERROR)
QUIT
End DoDot:2
QUIT
+30 SET DSUP=$PIECE(TEMP,U,8)
+31 IF DSUP=""
Begin DoDot:2
+32 SET IDEN=DA1_" missing days supply"
+33 DO ADDERROR^PXRMSXRM(GLOBAL,IDEN,.NERROR)
End DoDot:2
QUIT
+34 SET RDATE=+$PIECE($GET(^PSRX(DA1,2)),U,13)
+35 IF RDATE>0
Begin DoDot:2
+36 SET SDATE=+$$FMADD^XLFDT(RDATE,DSUP)
+37 SET DAS=DA1_";2"
+38 SET ^PXRMINDX(52,"IP",DRUG,DFN,RDATE,SDATE,DAS)=""
+39 SET ^PXRMINDX(52,"PI",DFN,DRUG,RDATE,SDATE,DAS)=""
+40 SET NE=NE+1
End DoDot:2
+41 ;Process the refill mutiple.
+42 SET DA=0
+43 FOR
SET DA=+$ORDER(^PSRX(DA1,1,DA))
if DA=0
QUIT
Begin DoDot:2
+44 SET TEMP=$GET(^PSRX(DA1,1,DA,0))
+45 SET DSUP=+$PIECE(TEMP,U,10)
+46 SET RDATE=+$PIECE(TEMP,U,18)
+47 IF RDATE>0
Begin DoDot:3
+48 SET SDATE=+$$FMADD^XLFDT(RDATE,DSUP)
+49 SET DAS=DA1_";1;"_DA_";0"
+50 SET ^PXRMINDX(52,"IP",DRUG,DFN,RDATE,SDATE,DAS)=""
+51 SET ^PXRMINDX(52,"PI",DFN,DRUG,RDATE,SDATE,DAS)=""
+52 SET NE=NE+1
End DoDot:3
End DoDot:2
+53 ;Process the partial fill multiple.
+54 SET DA=0
+55 FOR
SET DA=+$ORDER(^PSRX(DA1,"P",DA))
if DA=0
QUIT
Begin DoDot:2
+56 SET TEMP=$GET(^PSRX(DA1,"P",DA,0))
+57 SET DSUP=+$PIECE(TEMP,U,10)
+58 SET RDATE=+$PIECE(TEMP,U,19)
+59 IF RDATE>0
Begin DoDot:3
+60 SET SDATE=+$$FMADD^XLFDT(RDATE,DSUP)
+61 SET DAS=DA1_";P;"_DA_";0"
+62 SET ^PXRMINDX(52,"IP",DRUG,DFN,RDATE,SDATE,DAS)=""
+63 SET ^PXRMINDX(52,"PI",DFN,DRUG,RDATE,SDATE,DAS)=""
+64 SET NE=NE+1
End DoDot:3
End DoDot:2
End DoDot:1
+65 SET END=$HOROLOG
+66 SET TEXT=NE_" PRESCRIPTION results indexed."
+67 DO MES^XPDUTL(TEXT)
+68 SET TEXT=NERROR_" errors were encountered."
+69 DO MES^XPDUTL(TEXT)
+70 DO DETIME^PXRMSXRM(START,END)
+71 ;If there were errors send a message.
+72 IF NERROR>0
DO ERRMSG^PXRMSXRM(NERROR,GLOBAL)
+73 ;Send a MailMan message with the results.
+74 DO COMMSG^PXRMSXRM(GLOBAL,START,END,NE,NERROR)
+75 SET ^PXRMINDX(52,"GLOBAL NAME")=GLOBAL
+76 SET ^PXRMINDX(52,"BUILT BY")=DUZ
+77 SET ^PXRMINDX(52,"DATE BUILT")=$$NOW^XLFDT
+78 QUIT
+79 ;
