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

LRRP1.m

Go to the documentation of this file. 
  1. LRRP1 ;DALOI/RWF/BA-PRINT THE DATA FOR INTERIM REPORTS ; 13-Oct-2017 14:04 ;  MKK
  1.  ;;5.2;LAB SERVICE;**1004,1013,1016,153,221,283,1018,1025,1026,286,1027,1028,1030,1031,1033,1038,1039,1041**;NOV 01, 1997;Build 23
  1.  ;
  1.  ;from LRRP, LRRP2, LRRP3
  1.  ;
  1. PRINT S:'$L($G(SEX)) SEX="M" S:'$L($G(DOB)) DOB="UNKNOWN"
  1.  S LRAAO=0 F  S LRAAO=$O(^TMP("LR",$J,"TP",LRAAO)) Q:LRAAO<1  D ORDER Q:LRSTOP
  1.  K ^TMP("LR",$J,"TP")
  1.  Q
  1.  ;
  1.  ;
  1. ORDER N LRCAN
  1.  S LRCDT=0
  1.  F  S LRCDT=$O(^TMP("LR",$J,"TP",LRAAO,LRCDT)) Q:LRCDT<1  D
  1.  . S LRCAN=0
  1.  . I LRSS="CH" D
  1.  . . S LRIDT=+^TMP("LR",$J,"TP",LRAAO,LRCDT,-2)
  1.  . . F  S LRCAN=+$O(^LR(LRDFN,"CH",LRIDT,1,LRCAN)) Q:LRCAN<1  Q:$E($G(^(LRCAN,0)))="*"
  1.  . D TEST Q:LRSTOP
  1.  Q
  1.  ;
  1.  ;
  1. TEST ; EP -- IHS/OIT/MKK - LR*5.2*1027 - IHS Modified TEST Code
  1.  S LRIDT=+^TMP("LR",$J,"TP",LRAAO,LRCDT,-2)
  1.  S LRSS=$P(^TMP("LR",$J,"TP",LRAAO),U,2)
  1.  S LR0=$S($D(^(LRAAO,LRCDT))#2:^(LRCDT),1:""),LRTC=$P(LR0,U,12)
  1.  I LRSS="MI" D  Q
  1.  . S LRH=1 D:LRFOOT FOOT Q:LRSTOP
  1.  . D EN1^LRMIPC
  1.  . S LRHF=1,LRFOOT=0
  1.  . K A,Z,LRH
  1.  . S:LREND LREND=0,LRSTOP=1
  1.  ;
  1.  Q:'$G(LRCAN)&('$P(LR0,U,3))  D @$S(LRHF:"HDR",1:"CHECK") Q:LRSTOP
  1.  ;
  1.  I $P(XQY0,U)="LRRS"!($P(XQY0,U)="BLR LRRD BY MD")!($P(XQY0,U)="LRRS BY LOC")!($P(XQY0,U)="LRRD")!($P(XQY0,U)="LRRP2") D
  1.  . I $$ADDON^BLRUTIL("LR*5.2*1013","BLRALAF",DUZ(2)) D ^BLRALAU
  1.  ;
  1.  S LRSPEC=+$P(LR0,U,5),X=$P(LR0,U,10) D DOC^LRX
  1.  ;
  1.  D ORU             ; Accession info
  1.  ;
  1.  W !,?5,"Provider: ",LRDOC
  1.  ; D:'$G(BLRGUI) ESIGINFO^BLRUTIL3
  1.  ; D:'$G(BLRGUI) ESIGINFO^BLRUTIL5  ; IHS/MSC/MKK - LR*5.2*1033
  1.  D ARRIVETM^BLRUTIL8(LRDFN,LRSS,LRIDT) ; IHS/MSC/MKK - LR*5.2*1039 - Print Arrival Time
  1.  ; W !,?5,"Specimen:",$E($P(^LAB(61,LRSPEC,0),U),1,23)
  1.  W !,?5,"Specimen:",$E($P($G(^LAB(61,LRSPEC,0)),U),1,23)       ; Naked Ref fix - IHS/OIT/MKK - LR*5.2*1031
  1.  W ?42,"Spec Collect Date/Time:",$$FMTE^XLFDT(LRCDT,"2MZ")
  1.  ;
  1.  D CONDSPEC^BLRLRRP1    ; IHS/MSC/MKK - LR*5.2*1033
  1.  ;
  1.  D COLHEADS
  1.  ;
  1.  S LRPO=0
  1.  F  S LRPO=$O(^TMP("LR",$J,"TP",LRAAO,LRCDT,LRPO)) Q:LRPO'>0  S LRDATA=^(LRPO) D DATA Q:LRSTOP
  1.  Q:LRSTOP
  1.  ;
  1.  I $D(^TMP("LR",$J,"TP",LRAAO,LRCDT,"C")) D
  1.  . W !,"Comment: " S LRCMNT=0
  1.  . F  S LRCMNT=+$O(^TMP("LR",$J,"TP",LRAAO,LRCDT,"C",LRCMNT)) Q:LRCMNT<1  D  Q:LRSTOP
  1.  . . W ^TMP("LR",$J,"TP",LRAAO,LRCDT,"C",LRCMNT)
  1.  . . D CONT Q:LRSTOP
  1.  . . W:$O(^TMP("LR",$J,"TP",LRAAO,LRCDT,"C",LRCMNT)) !?9
  1.  Q:LRSTOP
  1.  D BOTTOMPG
  1.  Q
  1.  ;
  1. COLHEADS ; EP - IHS/OIT/MKK - LR*5.2*1027
  1.  ; W !!,"Test name"
  1.  ; W ?19,"Result    units"
  1.  W !,?25,"Res",!
  1.  W "Test name"
  1.  W ?18,"Result"
  1.  W ?25,"Flg"
  1.  W ?29,"units"
  1.  W ?43,"Ref.   range"
  1.  W ?60,"Site"
  1.  W ?66,"Result Dt/Time"
  1.  Q
  1.  ;
  1. BOTTOMPG ; EP - IHS/OIT/MKK - LR*5.2*1027
  1.  NEW STR
  1.  NEW IOM      ; IHS/MSC/MKK - LR*5.2*1038
  1.  S IOM=80     ; IHS/MSC/MKK - LR*5.2*1038
  1.  ;
  1.  W !,$TR($J("",IOM)," ","=")
  1.  ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1030 -- Add "Abnormal" & make two lines
  1.  ; S STR="KEY: A=Abnormal          L=Abnormal Low          H=Abnormal High"
  1.  ; W !,$$CJ^XLFSTR(STR,IOM)
  1.  ; S STR="*=Critical value          TR=Therapeutic Range"
  1.  ; W !,$$CJ^XLFSTR(STR,IOM)
  1.  ; ----- END IHS/OIT/MKK - LR*5.2*1030 -- Add "Abnormal" & make two lines
  1.  ;
  1.  ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1041 - Make one line
  1.  ; Make one line
  1.  W !,"KEY: A=Abnormal   L=Abnormal Low   H=Abnormal High   *=Critical   TR=Therapeutic",!
  1.  ; ----- END IHS/MSC/MKK - LR*5.2*1041
  1.  ;
  1.  S LRFOOT=1
  1.  Q
  1.  ; End - IHS/OIT/MKK - LR*5.2*1027 - IHS Modified TEST Code
  1.  ; 
  1.  ;
  1. DATA ; EP - Begin IHS/OIT/MKK - LR*5.2*1027 - IHS Modified DATA code
  1.  N LR63DATA
  1.  ;
  1.  S LRTSTS=+LRDATA,LRPC=$P(LRDATA,U,5),LRSUB=$P(LRDATA,U,6)
  1.  S X=$P(LRDATA,U,7) Q:X=""
  1.  S LR63DATA=$$TSTRES^LRRPU(LRDFN,LRSS,LRIDT,$P(LRDATA,U,10),LRTSTS)
  1.  ;
  1.  S LRLO=$P(LR63DATA,"^",3),LRHI=$P(LR63DATA,"^",4),LRREFS=$$EN^LRLRRVF(LRLO,LRHI),LRPLS=$P(LR63DATA,"^",6),LRTHER=$P(LR63DATA,"^",7)
  1.  ;
  1.  ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1033 - MU2 Special Code
  1.  S:$E(LRREFS,1,7)="Ref: <=" LRREFS=$TR(LRREFS,"=")
  1.  S:$E(LRREFS,1,7)="Ref: >=" LRREFS=$TR(LRREFS,"=")
  1.  ; ----- END IHS/MSC/MKK - LR*5.2*1033 - MU2 Special Code
  1.  ;
  1.  I LRPLS S LRPLS(LRPLS)=LRPLS
  1.  ;
  1.  W !,$S($L($P(LRDATA,U,2))>15:$P(LRDATA,U,3),1:$P(LRDATA,U,2))
  1.  S X=$P(LR63DATA,"^")
  1.  ; W ?16,@$S(LRPC="":"$J(X,LRCW)",1:LRPC)," ",$P(LR63DATA,"^",2)
  1.  W ?16,@$S(LRPC="":"$J(X,LRCW)",1:LRPC)
  1.  W ?26,$P(LR63DATA,"^",2)
  1.  ; W ?26,$S($P(LR63DATA,"^",2)="N":"",1:$P(LR63DATA,"^",2))
  1.  W ?29,$P(LR63DATA,"^",5)
  1.  I $G(LRREFS)["$S(" D MUMPRNGE(.LRREFS)
  1.  ; W ?43,$E(LRREFS,1,15)  K LRREFS
  1.  ; W ?55,$S(LRTHER:"(TR)",1:"")
  1.  ;
  1.  ; I LRPLS'="" W ?59,$J("["_LRPLS_"]",6)
  1.  ; W ?66,$$GETCOMPD^BLRUTIL4                       ; IHS/MSC/MKK - LR*5.2*1031
  1.  D LRREFS^BLRLRRP1      ; IHS/MSC/MKK - LR*5.2*1033
  1.  ;
  1.  D CONT Q:LRSTOP
  1.  ;
  1.  I $O(^TMP("LR",$J,"TP",LRAAO,LRCDT,LRPO,0))>0 D  Q:LRSTOP
  1.  . S LRINTP=0
  1.  . F  S LRINTP=+$O(^TMP("LR",$J,"TP",LRAAO,LRCDT,LRPO,LRINTP)) Q:LRINTP<1  W !?7,"Eval: ",^(LRINTP) D CONT Q:LRSTOP
  1.  ;
  1.  Q
  1.  ;
  1.  ;
  1. MUMPRNGE(RANGE) ; EP -- MUMPS Code in Reference Range -- Evaluate and store
  1.  NEW LOW,HIGH,RV1,RV2
  1.  ;
  1.  ; IHS/OIT/MKK - LR*5.2*1031 Note: 
  1.  ;     If there is only one (1) Reference Range for a test, the LRLRRVF routine returns the Single Ref Range
  1.  ;     with "Ref: " prefixed to it.  (See DATA+6 above.)  However, that Ref Range could have a $SELECT statement,
  1.  ;     which means it gets passed to this subroutine.  At this point, the RANGE variable must be a valid Mumps
  1.  ;     string, with no prefix.  The 1031 changes below will try to ensure that.
  1.  ;
  1.  S LOW=$$TRIM^XLFSTR($P(RANGE,"-"),"LR"," ")
  1.  S:$E(LOW,1,4)="Ref:" LOW=$P(LOW," ",2,999)           ; IHS/OIT/MKK - LR*5.2*1031 - Strip off "Ref: " string
  1.  ;
  1.  S HIGH=$$TRIM^XLFSTR($P(RANGE,"-",2),"LR"," ")
  1.  S:$E(HIGH,1,4)="Ref:" HIGH=$P(HIGH," ",2,999)        ; IHS/OIT/MKK - LR*5.2*1031 - Strip off "Ref: " string
  1.  ;
  1.  I $G(LOW)=""&($G(HIGH)="") S RANGE=" "  Q
  1.  ;
  1.  S RV1=$$MUMPEVAL(LOW)
  1.  S RV2=$$MUMPEVAL(HIGH)
  1.  ;
  1.  S RANGE=$$EN^LRLRRVF(RV1,RV2)
  1.  ;
  1.  ; I $G(RV1)=""&($G(RV2)="")  S RANGE=" "  Q
  1.  ;
  1.  ; S RANGE=RV1_" - "_RV2
  1.  Q
  1.  ;
  1. MUMPEVAL(EVAL) ; EP
  1.  NEW STR,WOT
  1.  ;
  1.  ; If no SELECT, just Return the string, BUT ... if the string contains punctuation, that means the
  1.  ; reference range code has been mis-parsed.  Return NULL.
  1.  I EVAL'["$S(" D  Q EVAL
  1.  .  I EVAL["("!(EVAL["?")!(EVAL["<")!(EVAL[")")!(EVAL["&") S EVAL=""
  1.  ;
  1.  ; If there is an "(" in the string, but no ")", that means the reference range code is too complex
  1.  ; and/or has been mis-parsed.  Return NULL.
  1.  I EVAL'[")" Q ""
  1.  ;
  1.  S STR="WOT="_EVAL
  1.  S @STR
  1.  ;
  1.  ; ANY punctuation in string means parsing failed.  Return NULL.
  1.  I WOT["("!(WOT["?")!(WOT["<")!(WOT[")")!(WOT["&") S WOT=""
  1.  ;
  1.  Q WOT
  1.  ;
  1. CHECK I LRTC+11>(IOSL-$Y) D FOOT Q:LRSTOP  D HDR
  1.  Q
  1.  ;
  1. CONT ; EP - Begin IHS/OIT/MKK - LR*5.2*1027 -- IHS Modified CONT code
  1.  ; Q:($Y+5)<IOSL
  1.  Q:($Y+9)<IOSL     ; IHS/MSC/MKK - LR*5.2*1038
  1.  ;
  1.  D BOTTOMPG
  1.  D FOOT
  1.  Q:LRSTOP
  1.  ;
  1.  D HDR
  1.  W !!,$$CJ^XLFSTR(">> CONTINUATION OF "_$P(LR0,U,6)_" <<",IOM)
  1.  D COLHEADS
  1.  Q
  1.  ; End IHS/OIT/MKK - LR*5.2*1027 -- IHS Modified CONT code
  1.  ;
  1.  ;
  1.  ; From LRRP, LRRP2, LRRP3
  1.  Q:LRSTOP                              ; If stop, then quit
  1.  Q:+$G(LREND)!(+$G(LRIDT)>+$G(LREDT))  ; Double check to stop -- IHS/OIT/MKK - LR*5.2*1030
  1.  ;
  1.  NEW LRIRAP,WOTERR
  1.  ;
  1.  S LRIRAP=$$GET1^DIQ(9009029,+$G(DUZ(2)),"INTERIM REPORT ADDRESS PAGE",,,"WOTERR")
  1.  I $G(LRIRAP)="NO"!($G(LRIRAP)="")  D
  1.  . NEW NUMSITES,WOTSITE
  1.  . S (NUMSITES,WOTSITE)=0
  1.  . F  S WOTSITE=$O(LRPLS(WOTSITE))  Q:WOTSITE=""  D
  1.  .. S NUMSITES=NUMSITES+1
  1.  .. I +$L($$NAME^XUAF4(WOTSITE))+$L($$PADD^XUAF4(WOTSITE))>IOM S NUMSITES=NUMSITES+1
  1.  . W !
  1.  . W:$Y'<(IOSL-(5+NUMSITES)) !
  1.  . F I=$Y:1:(IOSL-(5+NUMSITES)) W !    ; Get to "bottom" of the page
  1.  . D SITELIST^LRRP2                  ; Print sites & addresses
  1.  ;
  1.  ; Check again due to TRUE issues with the ELSE statement.
  1.  I $G(LRIRAP)="YES" F I=$Y:1:(IOSL-4) W !     ; "Go to" bottom of the page
  1.  I $G(LRIRAP)="YES" F I=$Y:1:(IOSL-5) W !   ; LR*5.2*1038 - "Go to" bottom of the page
  1.  ;
  1.  I $E(IOST,1,2)'="C-" D  Q
  1.  . NEW DONOTF                                    ; DO NOT FILE flag
  1.  . S DONOTF=$$GET1^DIQ(9009029,+$G(DUZ(2))_",3","INTERIM REPORT DO NOT FILE")
  1.  . I $G(DONOTF)["Y" W !,"INTERIM REPORT DO NOT FILE",?30,$E(PNM,1,23),"   HRCN:",HRCN,?70,LRDT0,!
  1.  . I $G(DONOTF)'["Y" W PNM,"   HRCN:",HRCN,?70,LRDT0,!
  1.  ;
  1.  ; W !,$E(PNM,1,23),?28,HRCN,?40,LRDT0
  1.  W !,PNM,?30,"  HRCN:",HRCN,?46,LRDT0    ; IHS/MSC/MKK - LR*5.2*1038
  1.  R ?60,"PRESS '^' TO STOP ",X:DTIME S:X="" X=1 S:(".^"[X)!('$T) LRSTOP=1
  1.  Q
  1.  ; End - IHS/OIT/MKK - LR*5.2*1027 - IHS Modified FOOT Code
  1.  ;
  1. HDR ; EP - Begin IHS/OIT/MKK - LR*5.2*1027 - IHS Modified HDR Code
  1.  W:($G(LRJ02))!($G(LRJ0))!($E(IOST,1,2)="C-") @IOF
  1.  S LRHF=0,LRJ02=1
  1.  I '$D(LRPG) S LRPG=0
  1.  S LRPG=LRPG+1
  1.  ; I $E(IOST,1)="P" W !!!!,$$CJ^XLFSTR("CLINICAL LABORATORY REPORT",IOM),!
  1.  I $E(IOST)'="C" W !!!!,$$CJ^XLFSTR("CLINICAL LABORATORY REPORT",80),!  ; IHS/MSC/MKK - LR*5.2*1038
  1.  I $D(DUZ("AG")),$L(DUZ("AG")),"ARMYAFN"[DUZ("AG") D ^LRAIPRIV W !
  1.  ; W "Printed at: ",?65,"page ",LRPG     ; IHS/OIT/MKK - LR*5.2*1028
  1.  ; W "Printed at: ",?65,"page ",LRPG,!     ; IHS/OIT/MKK - LR*5.2*1039
  1.  ;
  1.  ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1041
  1.  D
  1.  . NEW PAGESTR,TAB
  1.  . S PAGESTR="page "_LRPG
  1.  . S TAB=(IOM-$L(PAGESTR))-2
  1.  . W "Printed at: ",?TAB,PAGESTR,!
  1.  ; ----- END IHS/MSC/MKK - LR*5.2*1041
  1.  ;
  1.  D LABHDR^BLRUTIL2
  1.  W !,PNM,?45,"Date/Time Printed: ",$$FMTE^XLFDT($$NOW^XLFDT,"2MZ")
  1.  ;
  1.  NEW AGE
  1.  I +$P($G(^LR(LRDFN,0)),"^",2)=2 S DOB=$$DOB^AUPNPAT(+$P($G(^LR(LRDFN,0)),"^",3))   ; GIMC Correction
  1.  I DOB>0 D
  1.  . S AGE=$$UP^XLFSTR($$DATE^LRDAGE(DOB))    ; Age as of Today
  1.  . S:AGE["YR" AGE=+AGE                      ; If Age in Years, get rid of "YR" string.
  1.  ;
  1.  W !?5,"HRCN:",HRCN
  1.  ; W ?25,"SEX:",SEX
  1.  ; W ?35,"DOB:",$S(DOB>0:$$FMTE^XLFDT(DOB),1:" ")
  1.  ; W:+$G(AGE)>0 ?54,"CURRENT AGE:",AGE
  1.  ; ----- BEGIN IHS/OIT/MKK - LR*5.2*1030
  1.  W ?20,"SEX:",SEX
  1.  W ?27,"DOB:",$S(DOB>0:$$FMTE^XLFDT(DOB),1:" ")
  1.  ; W:+$G(AGE)>0 ?45,"CURRENT AGE:",AGE
  1.  ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1033
  1.  NEW DOD
  1.  ; S DOD=+$$GET1^DIQ(2,DFN,.351,"I")     ; Date of Death
  1.  S DOD=+$$GET1^DIQ(+$G(LRDPF),DFN,.351,"I")  ; IHS/MSC/MKK - LR*5.2*1041
  1.  ; W:'DOD&(AGE) ?45,"CURRENT AGE:",AGE
  1.  W:'DOD&(AGE)&('$$GET^XPAR("ALL","BLR DOB ONLY",1,"Q")) ?45,"CURRENT AGE:",AGE      ; IHS/MSC/MKK - LR*5.2*1041
  1.  W:DOD ?45,"DIED:",$$FMTE^XLFDT(DOD,"D")
  1.  ; ----- END IHS/MSC/MKK - LR*5.2*1033
  1.  NEW LOCIEN,LOCDESC
  1.  S LOCIEN=+$P($P(LR0,"^",13),";")
  1.  S LOCDESC=$P($G(^SC(LOCIEN,0)),"^")
  1.  ; W:$L(LOCDESC)<1!($L(LOCDESC)>14) ?62,"LOC:",LROC
  1.  ; W:$L(LOCDESC)>0&($L(LOCDESC)<15) ?62,"LOC:",LOCDESC
  1.  ; ----- END IHS/OIT/MKK - LR*5.2*1030
  1.  ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1031
  1.  W:$L(LOCDESC)<1!($L(LOCDESC)>12) ?64,"LOC:",$E(LROC,1,12)
  1.  W:$L(LOCDESC)>0&($L(LOCDESC)<12) ?64,"LOC:",LOCDESC
  1.  ; ----- END IHS/MSC/MKK - LR*5.2*1031
  1.  Q
  1.  ; End - IHS/OIT/MKK - LR*5.2*1027 - IHS Modified HDR Code
  1.  ;
  1. ORU ; Display remote ordering info if available
  1.  N LRX,IENS
  1.  ; S LRX=$G(^LR(LRDFN,"CH",LRIDT,"ORU")),IENS=LRIDT_","_LRDFN_","
  1.  ; D EN^DDIOL("Accession [UID]: "_$P(LR0,"^",6)_" ["_$P(LRX,"^")_"]","","!")
  1.  ;
  1.  ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1041
  1.  NEW LRZERO
  1.  S LRZERO=$G(^LR(LRDFN,LRSS,LRIDT,0)),LRX=$G(^("ORU")),IENS=LRIDT_","_LRDFN_","
  1.  D:$L(LRX) EN^DDIOL("Accession [UID]: "_$P(LRZERO,U,6)_" ["_$P(LRX,U)_"]")
  1.  ; ----- END IHS/MSC/MKK - LR*5.2*1041
  1.  ;
  1.  I $P(LRX,"^",3) D
  1.  . D EN^DDIOL("Ordering Site: "_$$GET1^DIQ(63.04,IENS,.33,""),"","!?2")
  1.  . D EN^DDIOL(" Ordering Site UID: "_$P(LRX,"^",5),"","?43")
  1.  I $P(LRX,"^",2) D EN^DDIOL("Collecting Site: "_$$GET1^DIQ(63.04,IENS,.32,""),"","!")
  1.  Q
  1.  ;
  1.  ; ----- BEGIN IHS/MSC/MKK - LR*5.2*1038
  1. LASTPAGE ; EP - Last Page
  1.  NEW CNT,HNOW,I
  1.  S (CNT,I)=0  F  S I=$O(LRPLS(I)) Q:I=""  S CNT=CNT+1
  1.  S CNT=CNT+1
  1.  I $E(IOST,1,2)="C-" F I=$Y:1:((IOSL-6)-CNT) W !
  1.  E  W !!
  1.  D SITELIST^LRRP2
  1.  W !!,PNM,?30,"  HRCN:",HRCN,?54,LRDT0
  1.  Q
  1.  ; ----- END IHS/MSC/MKK - LR*5.2*1038