Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BLRORBFX

BLRORBFX.m

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