Routine: ORPXRM

ORPXRM ; SLC/PKR - Clinical Reminder index routines for file 100. ;8/13/06  14:19

 ;;3.0;ORDER ENTRY/RESULTS REPORTING;**157,260**;Dec 17, 1997;Build 26

 ;DBIA 4113 supports PXRMSXRM entry points.

 ;DBIA 4114 supports setting and killing ^PXRMINDX

 ;=========================================================

INDEX ;Build the index for the ORDER file.

 N D0,D0P,D1,DAS,DFN,END,ENTRIES,ETEXT,FERROR,GLOBAL,IND,NE,NDUP,NERROR

 N OI,PROC,START,STRTDATE,STOP,TEMP,TENP,TEXT

 ;Don't leave any old stuff around.

 K ^PXRMINDX(100)

 S GLOBAL=$$GET1^DID(100,"","","GLOBAL NAME")

 S ENTRIES=$P(^OR(100,0),U,4)

 S TENP=ENTRIES/10

 S TENP=+$P(TENP,".",1)

 I TENP<1 S TENP=1

 D BMES^XPDUTL("Building index for ORDER file")

 S TEXT="There are "_ENTRIES_" entries to process."

 D MES^XPDUTL(TEXT)

 S START=$H

 S (D0,D0P,FERROR,IND,NDUP,NE,NERROR)=0

 F  S D0=$O(^OR(100,D0)) Q:(+D0=0)!(FERROR)  D

 . I D0'>D0P D  Q

 .. S FERROR=1

 .. S ETEXT=D0_" subscript is a bad, cannot continue!"

 .. D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)

 . S D0P=D0

 . 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(^OR(100,D0,0))

 . I TEMP="" D  Q

 .. S ETEXT=D0_" bad entry no 0 node"

 .. D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)

 . S DFN=$P(TEMP,U,2)

 . I DFN="" D  Q

 .. S ETEXT=D0_" no DFN"

 .. D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)

 . I DFN'["DPT(" Q

 . S DFN=$P(DFN,";",1)

 . S STRTDATE=$P(TEMP,U,8)

 .;If there is no start date get the release date for the new order.

 . I STRTDATE="" S STRTDATE=$$RDATE(D0)

 . I STRTDATE="" Q

 . S STOP=$P(TEMP,U,9)

 . S STOP=$S(STOP="":"U"_D0,1:STOP)

 . S D1=0

 . F  S D1=+$O(^OR(100,D0,.1,D1)) Q:D1=0  D

 .. S OI=^OR(100,D0,.1,D1,0)

 .. S DAS=D0_";.1;"_D1_";0"

 .. I OI="" D  Q

 ... S ETEXT=DAS_" no orderable item"

 ... D ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)

 .. I $D(^PXRMINDX(100,"IP",OI,DFN,STRTDATE,STOP,DAS)) S NDUP=NDUP+1

 .. S ^PXRMINDX(100,"IP",OI,DFN,STRTDATE,STOP,DAS)=""

 .. S ^PXRMINDX(100,"PI",DFN,OI,STRTDATE,STOP,DAS)=""

 .. S NE=NE+1

 S END=$H

 S TEXT=NE_" ORDER results indexed."

 W !,"There were "_NDUP_" duplicates."

 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(100,"GLOBAL NAME")=GLOBAL

 S ^PXRMINDX(100,"BUILT BY")=DUZ

 S ^PXRMINDX(100,"DATE BUILT")=$$NOW^XLFDT

 ;=========================================================

GETDATA(ORIFN,DATA) ;Return data, for a specified order file entry.

 N ORUPCHUK

 D EN^ORX8(ORIFN)

 S ORUPCHUK("ORORDER")=$$OI^ORX8(ORIFN)

 S ORUPCHUK("ORREL")=$$RDATE(ORIFN)

 M DATA=ORUPCHUK

 ;=========================================================

KOR(X,DA) ;Kill index for Order file.

 N DAS,DFN,STOP

 I X(1)'["DPT" Q

 I 'X(2)!'X(3) Q

 S DFN=$P(X(1),";",1)

 S DAS=DA(1)_";.1;"_DA_";0"

 S STOP=$S(X(4)="":"U"_DA(1),1:X(4))

 K ^PXRMINDX(100,"IP",X(2),DFN,X(3),STOP,DAS)

 K ^PXRMINDX(100,"PI",DFN,X(2),X(3),STOP,DAS)

 ;=========================================================

RDATE(ORIFN) ;Return the release date for the new order action.

 N RDIEN

 S RDIEN=$O(^OR(100,ORIFN,8,"C","NW",""))

 I RDIEN="" Q ""

 Q $P(^OR(100,ORIFN,8,RDIEN,0),U,16)

 ;=========================================================

SOR(X,DA) ;Set index for Order file.

 ;X(1)=OBJECT OF ORDER, X(2)=ORDERABLE ITEM, X(3)=START DATE

 ;or release date, X(4)=STOP DATE

 N DAS,DFN,STOP

 I X(1)'["DPT" Q

 I 'X(2)!'X(3) Q

 S DFN=$P(X(1),";",1)

 S DAS=DA(1)_";.1;"_DA_";0"

 S STOP=$S(X(4)="":"U"_DA(1),1:+X(4))

 S ^PXRMINDX(100,"IP",X(2),DFN,+X(3),STOP,DAS)=""

 S ^PXRMINDX(100,"PI",DFN,X(2),+X(3),STOP,DAS)=""

ORPXRM    ; SLC/PKR - Clinical Reminder index routines for file 100. ;8/13/06  14:19

 +1       ;;3.0;ORDER ENTRY/RESULTS REPORTING;**157,260**;Dec 17, 1997;Build 26

 +2       ;DBIA 4113 supports PXRMSXRM entry points.

 +3       ;DBIA 4114 supports setting and killing ^PXRMINDX

 +4       ;=========================================================

INDEX     ;Build the index for the ORDER file.

 +1        NEW D0,D0P,D1,DAS,DFN,END,ENTRIES,ETEXT,FERROR,GLOBAL,IND,NE,NDUP,NERROR

 +2        NEW OI,PROC,START,STRTDATE,STOP,TEMP,TENP,TEXT

 +3       ;Don't leave any old stuff around.

 +4        KILL ^PXRMINDX(100)

 +5        SET GLOBAL=$$GET1^DID(100,"","","GLOBAL NAME")

 +6        SET ENTRIES=$PIECE(^OR(100,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 index for ORDER file")

 +11       SET TEXT="There are "_ENTRIES_" entries to process."

 +12       DO MES^XPDUTL(TEXT)

 +13       SET START=$HOROLOG

 +14       SET (D0,D0P,FERROR,IND,NDUP,NE,NERROR)=0

 +15       FOR

               SET D0=$ORDER(^OR(100,D0))

               IF (+D0=0)!(FERROR)

                   QUIT

               Begin DoDot:1

 +16               IF D0'>D0P

                       Begin DoDot:2

 +17                       SET FERROR=1

 +18                       SET ETEXT=D0_" subscript is a bad, cannot continue!"

 +19                       DO ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)

                       End DoDot:2

                       QUIT

 +20               SET D0P=D0

 +21               SET IND=IND+1

 +22               IF IND#TENP=0

                       Begin DoDot:2

 +23                       SET TEXT="Processing entry "_IND

 +24                       DO MES^XPDUTL(TEXT)

                       End DoDot:2

 +25               IF IND#10000=0

                       WRITE "."

 +26               SET TEMP=$GET(^OR(100,D0,0))

 +27               IF TEMP=""

                       Begin DoDot:2

 +28                       SET ETEXT=D0_" bad entry no 0 node"

 +29                       DO ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)

                       End DoDot:2

                       QUIT

 +30               SET DFN=$PIECE(TEMP,U,2)

 +31               IF DFN=""

                       Begin DoDot:2

 +32                       SET ETEXT=D0_" no DFN"

 +33                       DO ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)

                       End DoDot:2

                       QUIT

 +34               IF DFN'["DPT("

                       QUIT

 +35               SET DFN=$PIECE(DFN,";",1)

 +36               SET STRTDATE=$PIECE(TEMP,U,8)

 +37      ;If there is no start date get the release date for the new order.

 +38               IF STRTDATE=""

                       SET STRTDATE=$$RDATE(D0)

 +39               IF STRTDATE=""

                       QUIT

 +40               SET STOP=$PIECE(TEMP,U,9)

 +41               SET STOP=$SELECT(STOP="":"U"_D0,1:STOP)

 +42               SET D1=0

 +43               FOR

                       SET D1=+$ORDER(^OR(100,D0,.1,D1))

                       IF D1=0

                           QUIT

                       Begin DoDot:2

 +44                       SET OI=^OR(100,D0,.1,D1,0)

 +45                       SET DAS=D0_";.1;"_D1_";0"

 +46                       IF OI=""

                               Begin DoDot:3

 +47                               SET ETEXT=DAS_" no orderable item"

 +48                               DO ADDERROR^PXRMSXRM(GLOBAL,ETEXT,.NERROR)

                               End DoDot:3

                               QUIT

 +49                       IF $DATA(^PXRMINDX(100,"IP",OI,DFN,STRTDATE,STOP,DAS))

                               SET NDUP=NDUP+1

 +50                       SET ^PXRMINDX(100,"IP",OI,DFN,STRTDATE,STOP,DAS)=""

 +51                       SET ^PXRMINDX(100,"PI",DFN,OI,STRTDATE,STOP,DAS)=""

 +52                       SET NE=NE+1

                       End DoDot:2

               End DoDot:1

 +53       SET END=$HOROLOG

 +54       SET TEXT=NE_" ORDER results indexed."

 +55       WRITE !,"There were "_NDUP_" duplicates."

 +56       DO MES^XPDUTL(TEXT)

 +57       DO DETIME^PXRMSXRM(START,END)

 +58      ;If there were errors send a message.

 +59       IF NERROR>0

               DO ERRMSG^PXRMSXRM(NERROR,GLOBAL)

 +60      ;Send a MailMan message with the results.

 +61       DO COMMSG^PXRMSXRM(GLOBAL,START,END,NE,NERROR)

 +62       SET ^PXRMINDX(100,"GLOBAL NAME")=GLOBAL

 +63       SET ^PXRMINDX(100,"BUILT BY")=DUZ

 +64       SET ^PXRMINDX(100,"DATE BUILT")=$$NOW^XLFDT

 +65       QUIT

 +66      ;

 +67      ;=========================================================

GETDATA(ORIFN,DATA) ;Return data, for a specified order file entry.

 +1        NEW ORUPCHUK

 +2        DO EN^ORX8(ORIFN)

 +3        SET ORUPCHUK("ORORDER")=$$OI^ORX8(ORIFN)

 +4        SET ORUPCHUK("ORREL")=$$RDATE(ORIFN)

 +5        MERGE DATA=ORUPCHUK

 +6        QUIT

 +7       ;

 +8       ;=========================================================

KOR(X,DA) ;Kill index for Order file.

 +1        NEW DAS,DFN,STOP

 +2        IF X(1)'["DPT"

               QUIT

 +3        IF 'X(2)!'X(3)

               QUIT

 +4        SET DFN=$PIECE(X(1),";",1)

 +5        SET DAS=DA(1)_";.1;"_DA_";0"

 +6        SET STOP=$SELECT(X(4)="":"U"_DA(1),1:X(4))

 +7        KILL ^PXRMINDX(100,"IP",X(2),DFN,X(3),STOP,DAS)

 +8        KILL ^PXRMINDX(100,"PI",DFN,X(2),X(3),STOP,DAS)

 +9        QUIT

 +10      ;=========================================================

RDATE(ORIFN) ;Return the release date for the new order action.

 +1        NEW RDIEN

 +2        SET RDIEN=$ORDER(^OR(100,ORIFN,8,"C","NW",""))

 +3        IF RDIEN=""

               QUIT ""

 +4        QUIT $PIECE(^OR(100,ORIFN,8,RDIEN,0),U,16)

 +5       ;

 +6       ;=========================================================

SOR(X,DA) ;Set index for Order file.

 +1       ;X(1)=OBJECT OF ORDER, X(2)=ORDERABLE ITEM, X(3)=START DATE

 +2       ;or release date, X(4)=STOP DATE

 +3        NEW DAS,DFN,STOP

 +4        IF X(1)'["DPT"

               QUIT

 +5        IF 'X(2)!'X(3)

               QUIT

 +6        SET DFN=$PIECE(X(1),";",1)

 +7        SET DAS=DA(1)_";.1;"_DA_";0"

 +8        SET STOP=$SELECT(X(4)="":"U"_DA(1),1:+X(4))

 +9        SET ^PXRMINDX(100,"IP",X(2),DFN,+X(3),STOP,DAS)=""

 +10       SET ^PXRMINDX(100,"PI",DFN,X(2),+X(3),STOP,DAS)=""

 +11       QUIT

 +12      ;

ORPXRM.m