BLRORBFX ;IHS/CIA/PLS - Fix Backdoor Lab orders in Order File;04-Nov-2004 18:51;PLS
;;5.2T9;LR;**1018**;Nov 17, 2004
;;1.1;VUECENTRIC RPMS SUPPORT;;Sep 14, 2004
;
EP ;
D EN^DDIOL($C(7)_$C(7)_$C(7)) ; Bell/Beep
D EN^DDIOL("Run from Label ONLY") ; Failsafe code
D EN^DDIOL(" ") ; Blank line
Q
;
; Changes have been made to the original CIAI routine.
; (1) There is now a menu to allow better user input
; (2) There is only a "view" mode and a "repair" mode
; (3) The user CANNOT select a beginning nor ending IEN.
; (4) Counts have been added.
;
; Original CIAI notes follow:
; The following entry point loops thru the Order File
; and identifies Lab Orders having Start Date, Stop Date or
; Release Date fields set to -1. This happened due to an
; empty VA Patch.
;
; The pointer to the Lab Order File is used to obtain the correct
; FileMan dates. The Order record is then updated.
; Input: SIEN - starting IEN (optional)
; EIEN - ending IEN (optional
; VIEW - 0- make changes; 1=view changes that will be made
;
; ================================ MAIN MENU ================================
PEP ; Private Entry Point for Main Menu
; -------------------------------- Variables --------------------------------
NEW OIEN,LABDAT,ORDAT,EMSG ; Original CIAI variables line
NEW BLRFMLA ; FileMan Line Array
NEW CNT ; Orders
NEW CNTBAD ; Orders with Date(s) Issue(s)
NEW CNTFIX ; Orders with Date(s) Issue(s) - Fixed
NEW CNTNOFIX ; Orders with Date(s) Issue(s) - NOT Fixed
NEW ARRYLN ; Line Array Line Number
NEW HEADER ; Header
NEW HEADER0 ; Site Name
NEW HEADER1,HEADER2,HEADER3,HEADER4,HEADER5,HEADER6 ; Heading 1-6
NEW LINE ; Menu Line
NEW MAX ; Max # of Menu Options
NEW MMSEL ; Main Menu SELection
NEW MMSTR ; Main Menu STRing
NEW PRGBEG ; PRoG BEG time
NEW PRGEND ; PRoG END time
NEW QFLG ; Quit Flag
NEW RTN ; RouTiNe
NEW STR ; Temp Variable
NEW TAB ; Tab
NEW TMP ; Temp Var
NEW BLRVERN ; BLR Ver #
NEW X,Y
;
S PRGBEG=$$NOW^XLFDT() ; Beg Date/Time
;
D MMDFMS ; "Main Menu" Setup
;
F D Q:MMSEL'>0 ; "Infinite loop"
. S HEADER1="Order Dates Repair"
. S HEADER2="MAIN MENU"
. S HEADER3=" " ; Blank line
. K HEADER4,HEADER5,HEADER6 ; "Clear out" potential lines
. ;
. D BLRGSHSH ; Generic Header
. ;
. D EN^DDIOL(.MMSTR) ; Display array via FILEMAN call
. ;
. D ^XBFMK ; Kernel call cleans up FILEMAN vars
. S DIR("A")="Select"
. S DIR(0)="NO^1:"_MAX
. D ^DIR
. S MMSEL=+Y
. I MMSEL<1 Q ; If nothing selected, Quit
. ;
. D ^XBFMK
. ;
. S STR=$G(DRTN(MMSEL)) ; Get routine "string"
. I STR="" Q ; If String = Null, just continue
. ;
. D @STR ; Do procedure
;
D ^XBCLS ; Clear screen and home cursor
;
S PRGEND=$$NOW^XLFDT() ; End Date/Time
;
K BLRFMLA
S BLRFMLA(1)="Total Time Used:"_$$FMDIFF^XLFDT(PRGEND,PRGBEG,3)
S BLRFMLA(2)=""
;
D EN^DDIOL(.BLRFMLA)
;
D ^XBFMK
;
Q
;
BLROVIEW ;
S HEADER2="View Order Dates Issues"
;
D BLRORDRF(,,1) ; Call CIAI routine with "view" flag
Q
;
BLROFIX ;
S HEADER2="Repair Order Dates Issues"
;
D BLRORDRF(,,0) ; Call CIAI routine with "fix" flag
Q
;
BLRORDRF(SIEN,EIEN,VIEW) ;
D BLRORDRI ; Initialize variables
;
F S OIEN=$O(^OR(100,OIEN)) Q:'OIEN!(OIEN>EIEN) D
.S CNT=CNT+1
.I $$ISLAB(OIEN) D
..I $$NEEDFIX(OIEN) D
...S CNTBAD=CNTBAD+1
...S LABDAT=$$LABDATES(OIEN) ; Lab Dates (Draw Time^
...S ORDAT=$$ORDATES(OIEN) ; Order Dates
...;
...I VIEW D Q ; Just show info
....K BLRFMLA ; Initialize
....;
....S $E(BLRFMLA(1),5)=OIEN
....S $E(BLRFMLA(2),15)=$P(LABDAT,"^",4) ; Lab Order Number
....;
....S $E(BLRFMLA(1),25)="Order"
....S $E(BLRFMLA(2),25)="Lab"
....D ORDTSETA ; Set Lab/Order Dates in array
....;
....D EN^DDIOL(.BLRFMLA)
...;
...N FDA
...I $P(ORDAT,U)<0 D
....S FDA(100,OIEN_",",21)=$P(LABDAT,U) ; Set Order Start Date
....D SSTRRSP(OIEN,$P(LABDAT,U)) ; Set Start Order Dialog item
...;
...S:$P(ORDAT,U,2)<0 FDA(100,OIEN_",",22)=$P(LABDAT,U,2) ; Set Order Stop Date
...S:$P(ORDAT,U,3)<0 FDA(100,OIEN_",",71)=$P(LABDAT,U,3) ; Set Results Date
...;
...D:$D(FDA) FILE^DIE("","FDA","EMSG") ; Fix it
...;
...; Reset
...S LABDAT=$$LABDATES(OIEN)
...S ORDAT=$$ORDATES(OIEN)
...;
...K BLRFMLA
...S BLRFMLA(1)=OIEN
...S $E(BLRFMLA(2),10)=$P(LABDAT,"^",4)
...S $E(BLRFMLA(1),28)="Order"
...S $E(BLRFMLA(2),28)="Lab"
...D ORDTSETA
...;
...I '$D(EMSG) D ; Order fixed
....S $E(BLRFMLA(1),21,23)="YES"
....S CNTFIX=CNTFIX+1
...;
...I $D(EMSG) D ; Order NOT fixed
....S $E(BLRFMLA(1),20,25)="**NO**"
....S CNTNOFIX=CNTNOFIX+1
...;
...D EN^DDIOL(.BLRFMLA)
;
; Ending message
K BLRFMLA
S BLRFMLA(1)=""
S BLRFMLA(2)="Number of orders analyzed = "_CNT
S BLRFMLA(3)=""
;
S ARRYLN=3 ; Initialize Array Line number
;
I $G(CNTBAD)>0 D BLREMSG("Number of orders with -1 Dates = ",CNTBAD)
;
I $G(CNTFIX)>0 D BLREMSG("Number of orders repaired = ",CNTFIX)
;
I $G(CNTNOFIX)>0 D
. D BLREMSG("Number of orders that COULD NOT be repaired = ",CNTNOFIX)
;
D EN^DDIOL(.BLRFMLA)
;
D BLRGPGR
;
Q
;
; Initialize variables
BLRORDRI ;
S VIEW=$G(VIEW,1)
S SIEN=$G(SIEN,1)
S EIEN=$G(EIEN,$O(^OR(100,$C(1)),-1))
S OIEN=SIEN-.1
;
S (CNT,CNTBAD,CNTFIX,CNTNOFIX)=0 ; Initialize counters
;
K HEADER3,HEADER4,HEADER5,HEADER6
;
S HEADER3=""
;
I VIEW=1 D
. S $E(HEADER4,5)="Order"
. S $E(HEADER4,15)="Lab Ord"
. S $E(HEADER5,5)="Number"
. S $E(HEADER5,15)="Number"
;
I VIEW=0 D
. S HEADER4="Order"
. S $E(HEADER4,10)="Lab Ord"
. S HEADER5="Number"
. S $E(HEADER5,10)="Number"
. S $E(HEADER5,20)="Repair"
;
S $E(HEADER5,35)="Start Date"
S $E(HEADER5,51)="Stop Date"
S $E(HEADER5,67)="Results Date"
;
S HEADER6=$TR($J("",80)," ","-") ; Dashed line
;
D BLRGSHSH ; Generic Header
;
Q
; Finds the START response and set into FDA Array
SSTRRSP(OIEN,DATE) ;
N STRIEN
S OIEN=","_OIEN_","
S STRIEN=$$FNDRSP(OIEN,"START")
S OIEN=STRIEN_OIEN
I STRIEN D
.S:$$GET1^DIQ(100.045,OIEN,1,"I")=-1 FDA(100.045,OIEN,1)=DATE
; Q:$Q STRIEN
Q
;
; Return IEN for given Response
FNDRSP(OIEN,RSP) ;
Q +$$FIND1^DIC(100.045,OIEN,,RSP,"ID")
;
; Returns boolean based on:
; Order Package = LAB SERVICE
ISLAB(IEN) ;
Q:'$G(IEN) 0
Q $$GET1^DIQ(100,IEN,12)="LAB SERVICE"
;
; Return Lab Order File Info
LRPTR(IEN) ;
Q $P($$GET1^DIQ(100,IEN,33,"I"),";",2,3)
;
; Return Lab Dates
; Input: ORDER IEN
; Output: Collection Date^Stop Date^Result Date
LABDATES(IEN) ;
N LRPTR,LRSDT,LRRDT,LRORDT,LRSN,ELON
; Stop date = Results date
S LRPTR=$$LRPTR(IEN)
S LRORDT=$P(LRPTR,";"),LRSN=$P(LRPTR,";",2)
S LRSDT=$$GET1^DIQ(69.01,LRSN_","_LRORDT_",",10,"I")
S LRRDT=$$GET1^DIQ(69.01,LRSN_","_LRORDT_",",21,"I")
;
S ELON=""
I LRORDT'=""&(LRSN'="") S ELON=$P($G(^LRO(69,LRORDT,1,LRSN,.1)),"^",1)
;
Q LRSDT_U_LRRDT_U_LRRDT_U_ELON
;
; Returns Order Dates
; Input: ORDER IEN
; Output: Start Date^Stop Date
ORDATES(IEN) ;
N ORSDT,ORSPDT,ORRDT
S ORSDT=$$GET1^DIQ(100,IEN,21,"I")
S ORSPDT=$$GET1^DIQ(100,IEN,22,"I")
S ORRDT=$$GET1^DIQ(100,IEN,71,"I")
Q ORSDT_U_ORSPDT_U_ORRDT
;
; Returns boolean value indicating presence of -1 dates
NEEDFIX(IEN) ;
N FIX
S FIX=0
S FIX=($$GET1^DIQ(100,IEN,21,"I")=-1) ; Start Date
S FIX=(FIX!($$GET1^DIQ(100,IEN,22,"I")=-1)) ; Stop Date
S FIX=(FIX!($$GET1^DIQ(100,IEN,71,"I")=-1)) ; Results Date
Q FIX
;
; Lab/Order Dates Set Array for output
ORDTSETA ;
S $E(BLRFMLA(1),35)=$P(ORDAT,"^",1)
S $E(BLRFMLA(1),51)=$P(ORDAT,"^",2)
S $E(BLRFMLA(1),67)=$P(ORDAT,"^",3)
;
S $E(BLRFMLA(2),35)=$P(LABDAT,"^",1)
S $E(BLRFMLA(2),51)=$P(LABDAT,"^",2)
S $E(BLRFMLA(2),67)=$P(LABDAT,"^",3)
Q
;
; Set Line Array with "messages" for ending of program
BLREMSG(MSG,CNTR) ;
S ARRYLN=ARRYLN+1
S $E(BLRFMLA(ARRYLN),5)=MSG_CNTR
S ARRYLN=ARRYLN+1
S BLRFMLA(ARRYLN)=""
;
Q
;
; Set up "Main Menu" as an array so as to take advantage of the EN^DDIOL
; FILEMAN routine. There can be no more than 99 menu items
MMDFMS ;
; Set up arrays here -- allows menu to be changed quickly in one area
K DRTN ; Initialize "Routines" array
S LINE=0 ; Initialize Line
S MAX=0 ; Maximum number of menu items
K MMSTR ; Initialize "Main Menu" array
S TAB=75 ; Initialize Tab
;
; Use MMSETSUB routine to set the MMSTR and DRTN arrays
D MMSETSUB("BLROVIEW","View Order Dates Issues")
D MMSETSUB("BLROFIX","Repair Order Dates Issues")
;
S MMSTR(LINE+1)=$J("",80) ; Blank line
;
; Center the Site's Name returned by Kernel Function
S HEADER0=$$CJ^XLFSTR($$LOC^XBFUNC,80)
;
S BLRVERN="1.00.00" ; Version number
Q
;
;Main Menu Setup Subsets
; Parameters are RTN = Mumps routine; MITEM = Menu ITEM
MMSETSUB(RTN,MITEM) ;
S MAX=MAX+1 ; Increment Max # Menu Items
S DRTN(MAX)=RTN ; Set Routine Call
S TAB=$S(TAB>35:5,TAB<35:45,1:5) ; Set Tab
I TAB=5 S LINE=LINE+1 ; Set Line
;
S $E(MMSTR(LINE),TAB)=$J(MAX,2)_") "_MITEM ; Set the array
Q
;
;Header Information; HEADER1 & HEADER2 must exist
BLRGSHSH ;
K HEADER
S HEADER(1)=HEADER0 ; Site Name
;
K BLRFMLA
;
S BLRFMLA=$$CJ^XLFSTR(HEADER1,80) ; Center Header string
S $E(BLRFMLA,1,13)="Date:"_$$NUMDATE($$DT^XLFDT()) ; Today's Date
S $E(BLRFMLA,65)=$J("Time:"_$$NUMTIME($$NOW^XLFDT()),16) ; Current Time
S BLRFMLA=$$TRIM^XLFSTR(BLRFMLA,"R"," ") ; Trim extra spaces
;
S HEADER(2)=BLRFMLA
;
K BLRFMLA
;
S BLRFMLA=$$CJ^XLFSTR(HEADER2,80)
S $E(BLRFMLA,70)=$J(BLRVERN,11) ; Version Number
S BLRFMLA=$$TRIM^XLFSTR(BLRFMLA,"R"," ")
S HEADER(3)=BLRFMLA
;
; Other Header lines as needed
F J=3:1:8 S STR="HEADER"_J Q:'$D(@STR) D
. S HEADER(J+1)=@STR
;
D ^XBCLS
D EN^DDIOL(.HEADER)
;
Q
;
; Generic "Press Any Key" Response
BLRGPGR ;
D EN^DDIOL(" ")
D ^XBFMK
S DIR(0)="E",(X,Y)=""
S DIR("A")="Press ANY Key"
D ^DIR
I $G(X)="^" S QFLG="Q" Q
;
Q
;
; Extract Date from FileMan Date into mm/dd/yy string
NUMDATE(FMDATE) ;
I FMDATE=0 Q " "
;
Q $E(FMDATE,4,5)_"/"_$E(FMDATE,6,7)_"/"_$E(FMDATE,2,3)
;
; Extract Time from FileMan Date/Time into xx:xx AM/PM string
NUMTIME(X) ;
NEW Y
S X=$E($P(X,".",2)_"0000",1,4),Y=X>1159 S:X>1259 X=X-1200 S X=$J(X\100,2)_":"_$E(X#100+100,2,3)_" "_$E("AP",Y+1)_"M"
Q X
BLRORBFX ;IHS/CIA/PLS - Fix Backdoor Lab orders in Order File;04-Nov-2004 18:51;PLS
+1 ;;5.2T9;LR;**1018**;Nov 17, 2004
+2 ;;1.1;VUECENTRIC RPMS SUPPORT;;Sep 14, 2004
+3 ;
EP ;
+1 ; Bell/Beep
DO EN^DDIOL($CHAR(7)_$CHAR(7)_$CHAR(7))
+2 ; Failsafe code
DO EN^DDIOL("Run from Label ONLY")
+3 ; Blank line
DO EN^DDIOL(" ")
+4 QUIT
+5 ;
+6 ; Changes have been made to the original CIAI routine.
+7 ; (1) There is now a menu to allow better user input
+8 ; (2) There is only a "view" mode and a "repair" mode
+9 ; (3) The user CANNOT select a beginning nor ending IEN.
+10 ; (4) Counts have been added.
+11 ;
+12 ; Original CIAI notes follow:
+13 ; The following entry point loops thru the Order File
+14 ; and identifies Lab Orders having Start Date, Stop Date or
+15 ; Release Date fields set to -1. This happened due to an
+16 ; empty VA Patch.
+17 ;
+18 ; The pointer to the Lab Order File is used to obtain the correct
+19 ; FileMan dates. The Order record is then updated.
+20 ; Input: SIEN - starting IEN (optional)
+21 ; EIEN - ending IEN (optional
+22 ; VIEW - 0- make changes; 1=view changes that will be made
+23 ;
+24 ; ================================ MAIN MENU ================================
PEP ; Private Entry Point for Main Menu
+1 ; -------------------------------- Variables --------------------------------
+2 ; Original CIAI variables line
NEW OIEN,LABDAT,ORDAT,EMSG
+3 ; FileMan Line Array
NEW BLRFMLA
+4 ; Orders
NEW CNT
+5 ; Orders with Date(s) Issue(s)
NEW CNTBAD
+6 ; Orders with Date(s) Issue(s) - Fixed
NEW CNTFIX
+7 ; Orders with Date(s) Issue(s) - NOT Fixed
NEW CNTNOFIX
+8 ; Line Array Line Number
NEW ARRYLN
+9 ; Header
NEW HEADER
+10 ; Site Name
NEW HEADER0
+11 ; Heading 1-6
NEW HEADER1,HEADER2,HEADER3,HEADER4,HEADER5,HEADER6
+12 ; Menu Line
NEW LINE
+13 ; Max # of Menu Options
NEW MAX
+14 ; Main Menu SELection
NEW MMSEL
+15 ; Main Menu STRing
NEW MMSTR
+16 ; PRoG BEG time
NEW PRGBEG
+17 ; PRoG END time
NEW PRGEND
+18 ; Quit Flag
NEW QFLG
+19 ; RouTiNe
NEW RTN
+20 ; Temp Variable
NEW STR
+21 ; Tab
NEW TAB
+22 ; Temp Var
NEW TMP
+23 ; BLR Ver #
NEW BLRVERN
+24 NEW X,Y
+25 ;
+26 ; Beg Date/Time
SET PRGBEG=$$NOW^XLFDT()
+27 ;
+28 ; "Main Menu" Setup
DO MMDFMS
+29 ;
+30 ; "Infinite loop"
FOR
Begin DoDot:1
+31 SET HEADER1="Order Dates Repair"
+32 SET HEADER2="MAIN MENU"
+33 ; Blank line
SET HEADER3=" "
+34 ; "Clear out" potential lines
KILL HEADER4,HEADER5,HEADER6
+35 ;
+36 ; Generic Header
DO BLRGSHSH
+37 ;
+38 ; Display array via FILEMAN call
DO EN^DDIOL(.MMSTR)
+39 ;
+40 ; Kernel call cleans up FILEMAN vars
DO ^XBFMK
+41 SET DIR("A")="Select"
+42 SET DIR(0)="NO^1:"_MAX
+43 DO ^DIR
+44 SET MMSEL=+Y
+45 ; If nothing selected, Quit
IF MMSEL<1
QUIT
+46 ;
+47 DO ^XBFMK
+48 ;
+49 ; Get routine "string"
SET STR=$GET(DRTN(MMSEL))
+50 ; If String = Null, just continue
IF STR=""
QUIT
+51 ;
+52 ; Do procedure
DO @STR
End DoDot:1
IF MMSEL'>0
QUIT
+53 ;
+54 ; Clear screen and home cursor
DO ^XBCLS
+55 ;
+56 ; End Date/Time
SET PRGEND=$$NOW^XLFDT()
+57 ;
+58 KILL BLRFMLA
+59 SET BLRFMLA(1)="Total Time Used:"_$$FMDIFF^XLFDT(PRGEND,PRGBEG,3)
+60 SET BLRFMLA(2)=""
+61 ;
+62 DO EN^DDIOL(.BLRFMLA)
+63 ;
+64 DO ^XBFMK
+65 ;
+66 QUIT
+67 ;
BLROVIEW ;
+1 SET HEADER2="View Order Dates Issues"
+2 ;
+3 ; Call CIAI routine with "view" flag
DO BLRORDRF(,,1)
+4 QUIT
+5 ;
BLROFIX ;
+1 SET HEADER2="Repair Order Dates Issues"
+2 ;
+3 ; Call CIAI routine with "fix" flag
DO BLRORDRF(,,0)
+4 QUIT
+5 ;
BLRORDRF(SIEN,EIEN,VIEW) ;
+1 ; Initialize variables
DO BLRORDRI
+2 ;
+3 FOR
SET OIEN=$ORDER(^OR(100,OIEN))
IF 'OIEN!(OIEN>EIEN)
QUIT
Begin DoDot:1
+4 SET CNT=CNT+1
+5 IF $$ISLAB(OIEN)
Begin DoDot:2
+6 IF $$NEEDFIX(OIEN)
Begin DoDot:3
+7 SET CNTBAD=CNTBAD+1
+8 ; Lab Dates (Draw Time^
SET LABDAT=$$LABDATES(OIEN)
+9 ; Order Dates
SET ORDAT=$$ORDATES(OIEN)
+10 ;
+11 ; Just show info
IF VIEW
Begin DoDot:4
+12 ; Initialize
KILL BLRFMLA
+13 ;
+14 SET $EXTRACT(BLRFMLA(1),5)=OIEN
+15 ; Lab Order Number
SET $EXTRACT(BLRFMLA(2),15)=$PIECE(LABDAT,"^",4)
+16 ;
+17 SET $EXTRACT(BLRFMLA(1),25)="Order"
+18 SET $EXTRACT(BLRFMLA(2),25)="Lab"
+19 ; Set Lab/Order Dates in array
DO ORDTSETA
+20 ;
+21 DO EN^DDIOL(.BLRFMLA)
End DoDot:4
QUIT
+22 ;
+23 NEW FDA
+24 IF $PIECE(ORDAT,U)<0
Begin DoDot:4
+25 ; Set Order Start Date
SET FDA(100,OIEN_",",21)=$PIECE(LABDAT,U)
+26 ; Set Start Order Dialog item
DO SSTRRSP(OIEN,$PIECE(LABDAT,U))
End DoDot:4
+27 ;
+28 ; Set Order Stop Date
IF $PIECE(ORDAT,U,2)<0
SET FDA(100,OIEN_",",22)=$PIECE(LABDAT,U,2)
+29 ; Set Results Date
IF $PIECE(ORDAT,U,3)<0
SET FDA(100,OIEN_",",71)=$PIECE(LABDAT,U,3)
+30 ;
+31 ; Fix it
IF $DATA(FDA)
DO FILE^DIE("","FDA","EMSG")
+32 ;
+33 ; Reset
+34 SET LABDAT=$$LABDATES(OIEN)
+35 SET ORDAT=$$ORDATES(OIEN)
+36 ;
+37 KILL BLRFMLA
+38 SET BLRFMLA(1)=OIEN
+39 SET $EXTRACT(BLRFMLA(2),10)=$PIECE(LABDAT,"^",4)
+40 SET $EXTRACT(BLRFMLA(1),28)="Order"
+41 SET $EXTRACT(BLRFMLA(2),28)="Lab"
+42 DO ORDTSETA
+43 ;
+44 ; Order fixed
IF '$DATA(EMSG)
Begin DoDot:4
+45 SET $EXTRACT(BLRFMLA(1),21,23)="YES"
+46 SET CNTFIX=CNTFIX+1
End DoDot:4
+47 ;
+48 ; Order NOT fixed
IF $DATA(EMSG)
Begin DoDot:4
+49 SET $EXTRACT(BLRFMLA(1),20,25)="**NO**"
+50 SET CNTNOFIX=CNTNOFIX+1
End DoDot:4
+51 ;
+52 DO EN^DDIOL(.BLRFMLA)
End DoDot:3
End DoDot:2
End DoDot:1
+53 ;
+54 ; Ending message
+55 KILL BLRFMLA
+56 SET BLRFMLA(1)=""
+57 SET BLRFMLA(2)="Number of orders analyzed = "_CNT
+58 SET BLRFMLA(3)=""
+59 ;
+60 ; Initialize Array Line number
SET ARRYLN=3
+61 ;
+62 IF $GET(CNTBAD)>0
DO BLREMSG("Number of orders with -1 Dates = ",CNTBAD)
+63 ;
+64 IF $GET(CNTFIX)>0
DO BLREMSG("Number of orders repaired = ",CNTFIX)
+65 ;
+66 IF $GET(CNTNOFIX)>0
Begin DoDot:1
+67 DO BLREMSG("Number of orders that COULD NOT be repaired = ",CNTNOFIX)
End DoDot:1
+68 ;
+69 DO EN^DDIOL(.BLRFMLA)
+70 ;
+71 DO BLRGPGR
+72 ;
+73 QUIT
+74 ;
+75 ; Initialize variables
BLRORDRI ;
+1 SET VIEW=$GET(VIEW,1)
+2 SET SIEN=$GET(SIEN,1)
+3 SET EIEN=$GET(EIEN,$ORDER(^OR(100,$CHAR(1)),-1))
+4 SET OIEN=SIEN-.1
+5 ;
+6 ; Initialize counters
SET (CNT,CNTBAD,CNTFIX,CNTNOFIX)=0
+7 ;
+8 KILL HEADER3,HEADER4,HEADER5,HEADER6
+9 ;
+10 SET HEADER3=""
+11 ;
+12 IF VIEW=1
Begin DoDot:1
+13 SET $EXTRACT(HEADER4,5)="Order"
+14 SET $EXTRACT(HEADER4,15)="Lab Ord"
+15 SET $EXTRACT(HEADER5,5)="Number"
+16 SET $EXTRACT(HEADER5,15)="Number"
End DoDot:1
+17 ;
+18 IF VIEW=0
Begin DoDot:1
+19 SET HEADER4="Order"
+20 SET $EXTRACT(HEADER4,10)="Lab Ord"
+21 SET HEADER5="Number"
+22 SET $EXTRACT(HEADER5,10)="Number"
+23 SET $EXTRACT(HEADER5,20)="Repair"
End DoDot:1
+24 ;
+25 SET $EXTRACT(HEADER5,35)="Start Date"
+26 SET $EXTRACT(HEADER5,51)="Stop Date"
+27 SET $EXTRACT(HEADER5,67)="Results Date"
+28 ;
+29 ; Dashed line
SET HEADER6=$TRANSLATE($JUSTIFY("",80)," ","-")
+30 ;
+31 ; Generic Header
DO BLRGSHSH
+32 ;
+33 QUIT
+34 ; Finds the START response and set into FDA Array
SSTRRSP(OIEN,DATE) ;
+1 NEW STRIEN
+2 SET OIEN=","_OIEN_","
+3 SET STRIEN=$$FNDRSP(OIEN,"START")
+4 SET OIEN=STRIEN_OIEN
+5 IF STRIEN
Begin DoDot:1
+6 IF $$GET1^DIQ(100.045,OIEN,1,"I")=-1
SET FDA(100.045,OIEN,1)=DATE
End DoDot:1
+7 ; Q:$Q STRIEN
+8 QUIT
+9 ;
+10 ; Return IEN for given Response
FNDRSP(OIEN,RSP) ;
+1 QUIT +$$FIND1^DIC(100.045,OIEN,,RSP,"ID")
+2 ;
+3 ; Returns boolean based on:
+4 ; Order Package = LAB SERVICE
ISLAB(IEN) ;
+1 IF '$GET(IEN)
QUIT 0
+2 QUIT $$GET1^DIQ(100,IEN,12)="LAB SERVICE"
+3 ;
+4 ; Return Lab Order File Info
LRPTR(IEN) ;
+1 QUIT $PIECE($$GET1^DIQ(100,IEN,33,"I"),";",2,3)
+2 ;
+3 ; Return Lab Dates
+4 ; Input: ORDER IEN
+5 ; Output: Collection Date^Stop Date^Result Date
LABDATES(IEN) ;
+1 NEW LRPTR,LRSDT,LRRDT,LRORDT,LRSN,ELON
+2 ; Stop date = Results date
+3 SET LRPTR=$$LRPTR(IEN)
+4 SET LRORDT=$PIECE(LRPTR,";")
SET LRSN=$PIECE(LRPTR,";",2)
+5 SET LRSDT=$$GET1^DIQ(69.01,LRSN_","_LRORDT_",",10,"I")
+6 SET LRRDT=$$GET1^DIQ(69.01,LRSN_","_LRORDT_",",21,"I")
+7 ;
+8 SET ELON=""
+9 IF LRORDT'=""&(LRSN'="")
SET ELON=$PIECE($GET(^LRO(69,LRORDT,1,LRSN,.1)),"^",1)
+10 ;
+11 QUIT LRSDT_U_LRRDT_U_LRRDT_U_ELON
+12 ;
+13 ; Returns Order Dates
+14 ; Input: ORDER IEN
+15 ; Output: Start Date^Stop Date
ORDATES(IEN) ;
+1 NEW ORSDT,ORSPDT,ORRDT
+2 SET ORSDT=$$GET1^DIQ(100,IEN,21,"I")
+3 SET ORSPDT=$$GET1^DIQ(100,IEN,22,"I")
+4 SET ORRDT=$$GET1^DIQ(100,IEN,71,"I")
+5 QUIT ORSDT_U_ORSPDT_U_ORRDT
+6 ;
+7 ; Returns boolean value indicating presence of -1 dates
NEEDFIX(IEN) ;
+1 NEW FIX
+2 SET FIX=0
+3 ; Start Date
SET FIX=($$GET1^DIQ(100,IEN,21,"I")=-1)
+4 ; Stop Date
SET FIX=(FIX!($$GET1^DIQ(100,IEN,22,"I")=-1))
+5 ; Results Date
SET FIX=(FIX!($$GET1^DIQ(100,IEN,71,"I")=-1))
+6 QUIT FIX
+7 ;
+8 ; Lab/Order Dates Set Array for output
ORDTSETA ;
+1 SET $EXTRACT(BLRFMLA(1),35)=$PIECE(ORDAT,"^",1)
+2 SET $EXTRACT(BLRFMLA(1),51)=$PIECE(ORDAT,"^",2)
+3 SET $EXTRACT(BLRFMLA(1),67)=$PIECE(ORDAT,"^",3)
+4 ;
+5 SET $EXTRACT(BLRFMLA(2),35)=$PIECE(LABDAT,"^",1)
+6 SET $EXTRACT(BLRFMLA(2),51)=$PIECE(LABDAT,"^",2)
+7 SET $EXTRACT(BLRFMLA(2),67)=$PIECE(LABDAT,"^",3)
+8 QUIT
+9 ;
+10 ; Set Line Array with "messages" for ending of program
BLREMSG(MSG,CNTR) ;
+1 SET ARRYLN=ARRYLN+1
+2 SET $EXTRACT(BLRFMLA(ARRYLN),5)=MSG_CNTR
+3 SET ARRYLN=ARRYLN+1
+4 SET BLRFMLA(ARRYLN)=""
+5 ;
+6 QUIT
+7 ;
+8 ; Set up "Main Menu" as an array so as to take advantage of the EN^DDIOL
+9 ; FILEMAN routine. There can be no more than 99 menu items
MMDFMS ;
+1 ; Set up arrays here -- allows menu to be changed quickly in one area
+2 ; Initialize "Routines" array
KILL DRTN
+3 ; Initialize Line
SET LINE=0
+4 ; Maximum number of menu items
SET MAX=0
+5 ; Initialize "Main Menu" array
KILL MMSTR
+6 ; Initialize Tab
SET TAB=75
+7 ;
+8 ; Use MMSETSUB routine to set the MMSTR and DRTN arrays
+9 DO MMSETSUB("BLROVIEW","View Order Dates Issues")
+10 DO MMSETSUB("BLROFIX","Repair Order Dates Issues")
+11 ;
+12 ; Blank line
SET MMSTR(LINE+1)=$JUSTIFY("",80)
+13 ;
+14 ; Center the Site's Name returned by Kernel Function
+15 SET HEADER0=$$CJ^XLFSTR($$LOC^XBFUNC,80)
+16 ;
+17 ; Version number
SET BLRVERN="1.00.00"
+18 QUIT
+19 ;
+20 ;Main Menu Setup Subsets
+21 ; Parameters are RTN = Mumps routine; MITEM = Menu ITEM
MMSETSUB(RTN,MITEM) ;
+1 ; Increment Max # Menu Items
SET MAX=MAX+1
+2 ; Set Routine Call
SET DRTN(MAX)=RTN
+3 ; Set Tab
SET TAB=$SELECT(TAB>35:5,TAB<35:45,1:5)
+4 ; Set Line
IF TAB=5
SET LINE=LINE+1
+5 ;
+6 ; Set the array
SET $EXTRACT(MMSTR(LINE),TAB)=$JUSTIFY(MAX,2)_") "_MITEM
+7 QUIT
+8 ;
+9 ;Header Information; HEADER1 & HEADER2 must exist
BLRGSHSH ;
+1 KILL HEADER
+2 ; Site Name
SET HEADER(1)=HEADER0
+3 ;
+4 KILL BLRFMLA
+5 ;
+6 ; Center Header string
SET BLRFMLA=$$CJ^XLFSTR(HEADER1,80)
+7 ; Today's Date
SET $EXTRACT(BLRFMLA,1,13)="Date:"_$$NUMDATE($$DT^XLFDT())
+8 ; Current Time
SET $EXTRACT(BLRFMLA,65)=$JUSTIFY("Time:"_$$NUMTIME($$NOW^XLFDT()),16)
+9 ; Trim extra spaces
SET BLRFMLA=$$TRIM^XLFSTR(BLRFMLA,"R"," ")
+10 ;
+11 SET HEADER(2)=BLRFMLA
+12 ;
+13 KILL BLRFMLA
+14 ;
+15 SET BLRFMLA=$$CJ^XLFSTR(HEADER2,80)
+16 ; Version Number
SET $EXTRACT(BLRFMLA,70)=$JUSTIFY(BLRVERN,11)
+17 SET BLRFMLA=$$TRIM^XLFSTR(BLRFMLA,"R"," ")
+18 SET HEADER(3)=BLRFMLA
+19 ;
+20 ; Other Header lines as needed
+21 FOR J=3:1:8
SET STR="HEADER"_J
IF '$DATA(@STR)
QUIT
Begin DoDot:1
+22 SET HEADER(J+1)=@STR
End DoDot:1
+23 ;
+24 DO ^XBCLS
+25 DO EN^DDIOL(.HEADER)
+26 ;
+27 QUIT
+28 ;
+29 ; Generic "Press Any Key" Response
BLRGPGR ;
+1 DO EN^DDIOL(" ")
+2 DO ^XBFMK
+3 SET DIR(0)="E"
SET (X,Y)=""
+4 SET DIR("A")="Press ANY Key"
+5 DO ^DIR
+6 IF $GET(X)="^"
SET QFLG="Q"
QUIT
+7 ;
+8 QUIT
+9 ;
+10 ; Extract Date from FileMan Date into mm/dd/yy string
NUMDATE(FMDATE) ;
+1 IF FMDATE=0
QUIT " "
+2 ;
+3 QUIT $EXTRACT(FMDATE,4,5)_"/"_$EXTRACT(FMDATE,6,7)_"/"_$EXTRACT(FMDATE,2,3)
+4 ;
+5 ; Extract Time from FileMan Date/Time into xx:xx AM/PM string
NUMTIME(X) ;
+1 NEW Y
+2 SET X=$EXTRACT($PIECE(X,".",2)_"0000",1,4)
SET Y=X>1159
IF X>1259
SET X=X-1200
SET X=$JUSTIFY(X\100,2)_":"_$EXTRACT(X#100+100,2,3)_" "_$EXTRACT("AP",Y+1)_"M"
+3 QUIT X
