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
Q
;
;=========================================================
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
Q
;
;=========================================================
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)
Q
;=========================================================
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)=""
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HORPXRM 3840 printed Oct 16, 2024@18:33:37 Page 2
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 ;
