- 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 Mar 13, 2025@21:38:07 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 ;
