LR450PIR ;VMP/JSG - LR*5.2*450 POST INSTALL ROUTINE KIDS INSTALL
;;5.2;LAB SERVICE;**450**;Sep 27, 1994;Build 1
;;Reference to ^SC is supported by DBIA 10040.
;Examines field #25 (INSTITUTION) in file #69 (LAB ORDER ENTRY)
;to identify records without an Institution specified. If the
;field is null, this routine uses field #23 (ORDERING LOCATION)
;to access file #44 (HOSPITAL LOCATION) and retrieve field #3
;(INSTITUTION) to use to populate the INSTITUTION field in the
;LAB ORDER ENTRY file.
;
;In some instances, the Ordering Location (#23) field is also
;null and consequently the Institution cannot be updated.
;
;Updated records are saved for 90 days in ^XTMP("LR450PIR").
;
;LRNE = Number records Examined
;LRNO = Number records Okay (INSTITUTION properly populated)
;LRNC = Number records Changed
;LRNN = Number records Not changed (though INSTITUTION null)
;LRIN = INSTITUTION
;LROL = ORDERING LOCATION
;
D MES^XPDUTL("In testing, the routine processed 250,000 lab orders per minute.")
D MES^XPDUTL("The routine will report progress every 100,000 orders.")
N LRNE,LRNO,LRNC,LRNN,LRIN,LROL,LRD0,LRD1,LRX
N LRRB,LR0,LRCD,LRPD
D INIT ;initialize ^XTMP
SCN S (LRD0,LRNE,LRNO,LRNC,LRNN)=0
F S LRD0=$O(^LRO(69,LRD0)),LRD1=0 Q:LRD0<1 D
. F S LRD1=$O(^LRO(69,LRD0,1,LRD1)) Q:LRD1<1 D CHK
W $C(10,13) I $D(^XTMP("LR450PIR",2)) S LRD0=0 D LCK
D MES^XPDUTL("Nodes Examined: "_LRNE)
D MES^XPDUTL("Nodes Okay: "_LRNO)
D MES^XPDUTL("Nodes Changed: "_LRNC)
D MES^XPDUTL("Nodes Not Changed: "_LRNN)
S ^XTMP("LR450PIR",1,"RECORD COUNTS")=LRNE_U_LRNO_U_LRNC_U_LRNN
S ^XTMP("LR450PIR",1,"RUN ENDED")=$$HTFM^XLFDT($H)
D MES^XPDUTL("Post Install Process complete.")
S LRX="To review updated records, use ^%G to list ^XTMP("
D MES^XPDUTL(LRX_$C(34)_"LR450PIR"_$C(34)_").")
END K LRNE,LRNO,LRNC,LRNN,LRIN,LROL,LRD0,LRD1,LRX
K LRRB,LR0,LRCD,LRPD
Q
LCK ;Give nodes LOCKed on the 1st pass, 1 more try:
D MES^XPDUTL("Checking LOCKed nodes ...")
F S LRD0=$O(^XTMP("LR450PIR",2,LRD0)),LRD1=0 Q:LRD0<1 D
. F S LRD1=$O(^XTMP("LR450PIR",2,LRD0,LRD1)) Q:LRD1<1 D
.. D CHK K ^XTMP("LR450PIR",2,LRD0,LRD1)
Q
CHK ;Examine 69.01 1 node to see if it needs to be properly updated:
S LRNE=LRNE+1 I '(LRNE#100000) D MES^XPDUTL("Orders Processed: "_LRNE_" ...")
I '$D(^LRO(69,LRD0,1,LRD1,1)) S LRNN=LRNN+1 Q ;no 1 node
I $P(^LRO(69,LRD0,1,LRD1,1),U,8)'="" S LRNO=LRNO+1 Q ;#25 okay
I '$D(^LRO(69,LRD0,1,LRD1,0)) S LRNN=LRNN+1 Q ;no 0 node
S LROL=$P(^LRO(69,LRD0,1,LRD1,0),U,9)
I LROL="" S LRNN=LRNN+1 Q ;#23 null
S LRON=+$G(^LRO(69,LRD0,1,LRD1,.1))
I 'LRON S LRNN=LRNN+1 Q ;no Order #
S LRIN=$P($G(^SC(LROL,0)),U,4)
I LRIN="" S LRNN=LRNN+1 Q ;no Institution in #44
L +^LRO(69,"C",LRON):$G(DILOCKTM,3) I '$T D Q
. S ^XTMP("LR450PIR",2,LRD0,LRD1)="",LRNE=LRNE-1 W "L"
S DIE="^LRO(69,"_LRD0_",1,",DA(1)=LRD0,DA=LRD1,DR="25////"_LRIN D ^DIE
L -^LRO(69,"C",LRON)
S ^XTMP("LR450PIR",LRD0,1,LRD1,1)=^LRO(69,LRD0,1,LRD1,1),LRNC=LRNC+1
Q
INIT ;Set up ^XTMP to save modified records:
;LRRB = PIR Run Begin date.time
;LRRE = PIR Run End date.time
;LRCD = ^XTMP Create Date
;LRPD = ^XTMP Purge Date
;LR0 = ^XTMP zero node data
S LRRB=$$HTFM^XLFDT($H),LRCD=$P(LRRB,"."),LRPD=$$FMADD^XLFDT(LRCD,30)
S LR0=LRPD_U_LRCD_U_"LR*5.2*450 Post Install: #69.01, Field #25"
S ^XTMP("LR450PIR",0)=LR0
S ^XTMP("LR450PIR",1,"RECORD COUNT LEGEND")="Examined^Okay^Changed^Not Changed"
S ^XTMP("LR450PIR",1,"RECORD COUNTS")="0^0^0^0"
S ^XTMP("LR450PIR",1,"RUN BEGAN")=LRRB
S ^XTMP("LR450PIR",1,"RUN ENDED")=""
S ^XTMP("LR450PIR",1,"UPDATED NODE LEGEND")="DTC^DTO^COL^C STA^VOL^COM^MO#^INS"
S ^XTMP("LR450PIR",2)="Records LOCKed during initial pass"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLR450PIR 4017 printed Apr 09, 2024@21:20:17 Page 2
LR450PIR ;VMP/JSG - LR*5.2*450 POST INSTALL ROUTINE KIDS INSTALL
+1 ;;5.2;LAB SERVICE;**450**;Sep 27, 1994;Build 1
+2 ;;Reference to ^SC is supported by DBIA 10040.
+3 ;Examines field #25 (INSTITUTION) in file #69 (LAB ORDER ENTRY)
+4 ;to identify records without an Institution specified. If the
+5 ;field is null, this routine uses field #23 (ORDERING LOCATION)
+6 ;to access file #44 (HOSPITAL LOCATION) and retrieve field #3
+7 ;(INSTITUTION) to use to populate the INSTITUTION field in the
+8 ;LAB ORDER ENTRY file.
+9 ;
+10 ;In some instances, the Ordering Location (#23) field is also
+11 ;null and consequently the Institution cannot be updated.
+12 ;
+13 ;Updated records are saved for 90 days in ^XTMP("LR450PIR").
+14 ;
+15 ;LRNE = Number records Examined
+16 ;LRNO = Number records Okay (INSTITUTION properly populated)
+17 ;LRNC = Number records Changed
+18 ;LRNN = Number records Not changed (though INSTITUTION null)
+19 ;LRIN = INSTITUTION
+20 ;LROL = ORDERING LOCATION
+21 ;
+22 DO MES^XPDUTL("In testing, the routine processed 250,000 lab orders per minute.")
+23 DO MES^XPDUTL("The routine will report progress every 100,000 orders.")
+24 NEW LRNE,LRNO,LRNC,LRNN,LRIN,LROL,LRD0,LRD1,LRX
+25 NEW LRRB,LR0,LRCD,LRPD
+26 ;initialize ^XTMP
DO INIT
SCN SET (LRD0,LRNE,LRNO,LRNC,LRNN)=0
+1 FOR
SET LRD0=$ORDER(^LRO(69,LRD0))
SET LRD1=0
if LRD0<1
QUIT
Begin DoDot:1
+2 FOR
SET LRD1=$ORDER(^LRO(69,LRD0,1,LRD1))
if LRD1<1
QUIT
DO CHK
End DoDot:1
+3 WRITE $CHAR(10,13)
IF $DATA(^XTMP("LR450PIR",2))
SET LRD0=0
DO LCK
+4 DO MES^XPDUTL("Nodes Examined: "_LRNE)
+5 DO MES^XPDUTL("Nodes Okay: "_LRNO)
+6 DO MES^XPDUTL("Nodes Changed: "_LRNC)
+7 DO MES^XPDUTL("Nodes Not Changed: "_LRNN)
+8 SET ^XTMP("LR450PIR",1,"RECORD COUNTS")=LRNE_U_LRNO_U_LRNC_U_LRNN
+9 SET ^XTMP("LR450PIR",1,"RUN ENDED")=$$HTFM^XLFDT($HOROLOG)
+10 DO MES^XPDUTL("Post Install Process complete.")
+11 SET LRX="To review updated records, use ^%G to list ^XTMP("
+12 DO MES^XPDUTL(LRX_$CHAR(34)_"LR450PIR"_$CHAR(34)_").")
END KILL LRNE,LRNO,LRNC,LRNN,LRIN,LROL,LRD0,LRD1,LRX
+1 KILL LRRB,LR0,LRCD,LRPD
+2 QUIT
LCK ;Give nodes LOCKed on the 1st pass, 1 more try:
+1 DO MES^XPDUTL("Checking LOCKed nodes ...")
+2 FOR
SET LRD0=$ORDER(^XTMP("LR450PIR",2,LRD0))
SET LRD1=0
if LRD0<1
QUIT
Begin DoDot:1
+3 FOR
SET LRD1=$ORDER(^XTMP("LR450PIR",2,LRD0,LRD1))
if LRD1<1
QUIT
Begin DoDot:2
+4 DO CHK
KILL ^XTMP("LR450PIR",2,LRD0,LRD1)
End DoDot:2
End DoDot:1
+5 QUIT
CHK ;Examine 69.01 1 node to see if it needs to be properly updated:
+1 SET LRNE=LRNE+1
IF '(LRNE#100000)
DO MES^XPDUTL("Orders Processed: "_LRNE_" ...")
+2 ;no 1 node
IF '$DATA(^LRO(69,LRD0,1,LRD1,1))
SET LRNN=LRNN+1
QUIT
+3 ;#25 okay
IF $PIECE(^LRO(69,LRD0,1,LRD1,1),U,8)'=""
SET LRNO=LRNO+1
QUIT
+4 ;no 0 node
IF '$DATA(^LRO(69,LRD0,1,LRD1,0))
SET LRNN=LRNN+1
QUIT
+5 SET LROL=$PIECE(^LRO(69,LRD0,1,LRD1,0),U,9)
+6 ;#23 null
IF LROL=""
SET LRNN=LRNN+1
QUIT
+7 SET LRON=+$GET(^LRO(69,LRD0,1,LRD1,.1))
+8 ;no Order #
IF 'LRON
SET LRNN=LRNN+1
QUIT
+9 SET LRIN=$PIECE($GET(^SC(LROL,0)),U,4)
+10 ;no Institution in #44
IF LRIN=""
SET LRNN=LRNN+1
QUIT
+11 LOCK +^LRO(69,"C",LRON):$GET(DILOCKTM,3)
IF '$TEST
Begin DoDot:1
+12 SET ^XTMP("LR450PIR",2,LRD0,LRD1)=""
SET LRNE=LRNE-1
WRITE "L"
End DoDot:1
QUIT
+13 SET DIE="^LRO(69,"_LRD0_",1,"
SET DA(1)=LRD0
SET DA=LRD1
SET DR="25////"_LRIN
DO ^DIE
+14 LOCK -^LRO(69,"C",LRON)
+15 SET ^XTMP("LR450PIR",LRD0,1,LRD1,1)=^LRO(69,LRD0,1,LRD1,1)
SET LRNC=LRNC+1
+16 QUIT
INIT ;Set up ^XTMP to save modified records:
+1 ;LRRB = PIR Run Begin date.time
+2 ;LRRE = PIR Run End date.time
+3 ;LRCD = ^XTMP Create Date
+4 ;LRPD = ^XTMP Purge Date
+5 ;LR0 = ^XTMP zero node data
+6 SET LRRB=$$HTFM^XLFDT($HOROLOG)
SET LRCD=$PIECE(LRRB,".")
SET LRPD=$$FMADD^XLFDT(LRCD,30)
+7 SET LR0=LRPD_U_LRCD_U_"LR*5.2*450 Post Install: #69.01, Field #25"
+8 SET ^XTMP("LR450PIR",0)=LR0
+9 SET ^XTMP("LR450PIR",1,"RECORD COUNT LEGEND")="Examined^Okay^Changed^Not Changed"
+10 SET ^XTMP("LR450PIR",1,"RECORD COUNTS")="0^0^0^0"
+11 SET ^XTMP("LR450PIR",1,"RUN BEGAN")=LRRB
+12 SET ^XTMP("LR450PIR",1,"RUN ENDED")=""
+13 SET ^XTMP("LR450PIR",1,"UPDATED NODE LEGEND")="DTC^DTO^COL^C STA^VOL^COM^MO#^INS"
+14 SET ^XTMP("LR450PIR",2)="Records LOCKed during initial pass"
+15 QUIT
