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

LRVR4.m

Go to the documentation of this file. 
  1. LRVR4 ;DALOI/CJS/DALOI/FHS - LAB ROUTINE DATA VERIFICATION ;JUL 06, 2010 3:14 PM
  1.  ;;5.2;LAB SERVICE;**14,42,121,153,221,263,279,283,287,286,330,1027**;NOV 01, 1997
  1.  I $D(LRSBCOM) D
  1.  . N LRX
  1.  . S LRX=0
  1.  . F  S LRX=$O(LRSBCOM(LRX)) Q:LRX=""  S ^LAH(LRLL,1,LRSQ,1,LRX)=LRSBCOM(LRX)
  1.  K %,LRSBCOM
  1.  D LOOP
  1.  Q
  1.  ;
  1.  ;
  1. LOOP ; EP
  1.  S LRLCT=0
  1.  ; W !!,PNM,"   SSN: ",SSN,"   "
  1.  W !!,PNM,"  HRCN: ",HRCN,"   "        ; IHS/OIT/MKK - LR*5.2*1027
  1.  I LRDPF=2 W "   LOC: ",$S(LRWRD'="":LRWRD,1:$S($L($P(^LRO(68,LRAA,1,LRAD,1,LRAN,0),U,7)):$P(^(0),U,7),1:"??"))
  1.  W !,"Pat Info: ",$P($G(^LR(LRDFN,.091)),U)
  1.  ; W ?34," Sex: ",$S(SEX="M":"MALE",SEX="F":"FEMALE",1:SEX)
  1.  W ?34," Sex: " W:$L($G(SEX)) $S(SEX="M":"MALE",SEX="F":"FEMALE",1:SEX)   ; IHS/OIT/MKK - LR*5.2*1027
  1.  ; W ?48," Age: ",$$CALCAGE^LRRPU(DOB,LRCDT)," as of ",$$FMTE^XLFDT(LRCDT,"1D")
  1.  W ?48," Age: ",$$CALCAGE^LRRPU(+$G(VADM(3)),LRCDT)," as of ",$$FMTE^XLFDT(LRCDT,"1D")   ; IHS/OIT/MKK - LR*5.2*1027
  1.  S LRPRAC=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,0),U,8)
  1.  I LRPRAC>0,LRPRAC=+LRPRAC D GETS^DIQ(200,LRPRAC_",",".01;.132;.137;.138","E","LRPRAC(LRPRAC)","LRERR")
  1.  W !,"Provider: "
  1.  S LRLCT=LRLCT+3
  1.  I LRPRAC'="",'$D(LRPRAC(LRPRAC,200)) W LRPRAC
  1.  I LRPRAC,$D(LRPRAC(LRPRAC,200)) D
  1.  . W LRPRAC(LRPRAC,200,LRPRAC_",",.01,"E"),?40," Voice pager: ",LRPRAC(LRPRAC,200,LRPRAC_",",.137,"E")
  1.  . W !,"   Phone: ",LRPRAC(LRPRAC,200,LRPRAC_",",.132,"E"),?38," Digital pager: ",LRPRAC(LRPRAC,200,LRPRAC_",",.138,"E")
  1.  . S LRLCT=LRLCT+1
  1.  ;
  1.  N PRAC,PR
  1.  D PRAC^LR7OMERG(LRAA,LRAD,LRAN,.PRAC)
  1.  I $O(PRAC(0)) D
  1.  . S PR=0
  1.  . F  S PR=$O(PRAC(PR)) Q:PR<1  I $D(^VA(200,PR,0)) W !?14,$P(^(0),"^") S LRLCT=LRLCT+1
  1.  ;
  1.  W ! S LRNX=0,LRVRM=1,Z=LRCDT,LRLCT=LRLCT+1
  1.  I $P(Z1,U,7)'="" W !,"VOLUME: ",$P(Z1,U,7) S LRLCT=LRLCT+1
  1.  S LRACC=$P(Z1,U,6)
  1.  W !,"ACCESSION:",?30,$P(Z2,U,6),?44," ",LRACC
  1.  W !,LRPANEL,?30,LRDAT(2),?44," ",LRDAT
  1.  S LRLCT=LRLCT+2
  1.  I $D(LRALERT),LRALERT<($P(LRPARAM,U,20)+1) D
  1.  . W !?15 W:$E(IOST,1,2)="C-" @LRVIDO
  1.  . W "Test ordered "_$P($G(^LAB(62.05,+LRALERT,0)),U)
  1.  . W:$E(IOST,1,2)="C-" @LRVIDOF,$C(7)
  1.  . S LRLCT=LRLCT+1
  1.  I $D(LRGVP) D V20 Q
  1.  I ($O(LRSB(0))<1!$D(LRPER))&'$D(LRNUF) D LRSBCOM G EDIT
  1.  K LRNUF
  1.  D V20:'$D(LRPER) Q:$O(LRSB(1))<1  G:LREDIT EDIT
  1. V36 ;
  1.  S LRTEC=$S($D(^LRO(68,LRAA,1,LRAD,2)):$P(^(2),U),1:$S($D(LRUSI):LRUSI,1:"")),LREDIT=0
  1.  ;
  1. V3 ;
  1.  D LRSBCOM,DCOM^LRVERA
  1.  ;
  1.  ; If entering reference lab results only allow editing comments/workload
  1.  K DIR
  1.  S LRLCT=0
  1.  I $G(LRDUZ(2)),DUZ(2)'=LRDUZ(2) D
  1.  . S DIR(0)="SAO^C:Comments;W:Workload"
  1.  . S DIR("A")="SELECT ('C' for Comments, 'W' Workload): "
  1.  E  D
  1.  . S DIR(0)="SAO^E:Edit;C:Comments;W:Workload"
  1.  . S DIR("A")="SELECT ('E' to Edit, 'C' for Comments, 'W' Workload): "
  1.  D ^DIR
  1.  I $D(DIRUT) S X="^" G V37
  1.  S X=Y
  1.  S:$E(X)="E" LREDIT=1,X=""
  1.  I X="C" D COM G LOOP
  1.  ;
  1.  I $E(X)="W" D  G LOOP
  1.  . I $P(LRPARAM,U,14),$P($G(^LRO(68,LRAA,0)),U,16) D STD^LRCAPV,EN^LRCAPV S LREND=0 Q
  1.  . W !?10,"Workload is not activated. "
  1.  ;
  1.  S X=$S(X="@":"",X="":LRTEC,1:X),LRTEC=X
  1.  S:'$D(^LRO(68,LRAA,1,LRAD,2)) ^(2)="" S ^(2)=X_U_$P(^(2),U,2,99)
  1.  G EDIT:LREDIT
  1. V37 Q  ;LEAVE LRVR4, BACK TO LRVR3
  1.  ;
  1.  ;
  1. V25 ;
  1.  I LRVF K LRSB(LRSB),LRM(LRSB) Q
  1.  I '$D(LRSB(LRSB)) S LRSB(LRSB)=^LR(LRDFN,LRSS,LRIDT,LRSB) Q
  1.  Q
  1.  ;
  1.  ;
  1. V20 S LRNX=$O(LRORD(LRNX)) G V35:LRNX<1 D SUBS G V20:'LRTS
  1.  I $D(^LR(LRDFN,LRSS,LRIDT,LRSB)),^(LRSB)'["pending" D V25 G:LRVF V20
  1.  I "CH"'=LRSS G V20
  1.  D V25^LRVR5
  1.  W !,$P(^LAB(60,+LRTS,0),U)
  1.  S X1=""
  1.  I $D(^LR(LRDFN,LRSS,LRLDT,LRSB)) D
  1.  . S X1=$P(^(LRSB),U),(LRDL,X)=X1
  1.  . I $$GET1^DID(63.04,LRSB,"","TYPE","","LRERR")="SET" D
  1.  . . S X=$$EXTERNAL^DILFD(63.04,LRSB,"",X1)
  1.  . . I X="" S X=X1
  1.  . W:X'="" ?30,@LRFP
  1.  S X="",LRFLG=""
  1.  I $D(LRSB(LRSB)),$P(LRSB(LRSB),U)'="" D
  1.  . N LRX
  1.  . K LRNOVER(LRSB)
  1.  . S (LRDL,LRX,X)=$P(LRSB(LRSB),U)
  1.  . I $$GET1^DID(63.04,LRSB,"","TYPE","","LRERR")="SET" D
  1.  . . S X=$$EXTERNAL^DILFD(63.04,LRSB,"",LRX)
  1.  . . I X="" S X=LRX
  1.  . W ?44," ",@LRFP," "
  1.  . S X=LRX,Y=0
  1.  . K LRQ
  1.  . I X="" Q
  1.  . I (X="canc")!(X="comment")!(X="pending") D  Q
  1.  . . W LRFLG,?56," ",$P(LRNG,U,7)
  1.  . . S LREDIT=0
  1.  . I LRDEL'="" S LRQ=1,LRVRM=11 X LRDEL S LRVRM=1 K LRQ
  1.  . D RANGE
  1.  . W LRFLG,?56," ",$P(LRNG,U,7) S:X'="" LREDIT=0
  1.  I '$D(LRNUF) S LRLCT=LRLCT+1 S:$X>80 LRLCT=LRLCT+1 D:LRLCT>22 WT G:$G(Y)'="^" V20
  1.  ;
  1. V35 ;
  1.  D LRCFL:LRCFL]""
  1.  K LRNUF
  1.  Q
  1.  ;
  1.  ;
  1. LRCFL ;
  1.  S LREXEC=LRCFL D ^LREXEC:LRCFL[""
  1.  D:LRLCT>22 WT
  1.  Q
  1.  ;
  1.  ;
  1. EDIT ;
  1.  S LROUT=1 D ^LRVR5
  1.  S LRVRM=1,LREDIT=0
  1.  G LRCFL:LROUT!$D(LRPER),LOOP
  1.  ;
  1.  ;
  1. RANGE ;
  1.  ; If results from another system, use flags returned with results
  1.  ; and set LRNG,LRNGS with normals from message.
  1.  ; Check for LRDUZ(2) set for performing lab or performing lab set (piece 9) in LRSB(LRSB) array.
  1.  I $G(LRDUZ(2)),DUZ(2)'=LRDUZ(2) S Y=X D PLNR,CKPLNR,RQ Q
  1.  I $P(LRSB(LRSB),"^",9),DUZ(2)'=$P(LRSB(LRSB),"^",9) S Y=X D PLNR,CKPLNR,RQ Q
  1.  ;
  1.  D RANGE^LRVER4,RQ
  1.  Q
  1.  ;
  1.  ;
  1. RQ S X=Y
  1. NR I $D(LRSB(LRSB))#2 D
  1.  . N I,LRX,LRY
  1.  . I $P(X,U)="" S LRSB(LRSB)="" Q
  1.  . S $P(LRSB(LRSB),U)=X
  1.  . S $P(LRSB(LRSB),U,2)=LRFLG
  1.  . S $P(LRSB(LRSB),U,4)=$S($G(LRDUZ):LRDUZ,1:$G(DUZ))
  1.  . I $P(LRSB(LRSB),U,9)="" S $P(LRSB(LRSB),U,9)=$S($G(LRDUZ(2)):LRDUZ(2),$G(DUZ(2)):DUZ(2),1:"")
  1.  . S LRX=$$TMPSB^LRVER1(LRSB),LRY=$P(LRSB(LRSB),U,3)
  1.  . F I=1:1:$L(LRX,"!") I $P(LRY,"!",I)="" S $P(LRY,"!",I)=$P(LRX,"!",I)
  1.  . S $P(LRSB(LRSB),U,3)=LRY
  1.  . I $P($P(LRSB(LRSB),U,3),"!")="" D RONLT^LRVER3
  1.  . S LRX=LRNGS,LRY=$P(LRSB(LRSB),U,5)
  1.  . F I=1:1:$L(LRX,U) I $P(LRY,"!",I)="" S $P(LRY,"!",I)=$P(LRX,U,I)
  1.  . S $P(LRSB(LRSB),U,5)=LRY
  1.  Q
  1.  ;
  1.  ;
  1. PLNR ; Performing lab normal ranges, use instead of current local ranges
  1.  ; Retrieve from results when "NPC" node = 2 or greater
  1.  ; and set LRNG and LRNGS with normals from HL7 message/interface.
  1.  N I,LRY
  1.  I +$G(^LR(LRDFN,LRSS,LRIDT,"NPC"))<2 Q
  1.  S LRY=$P($G(LRSB(LRSB)),"^",5)
  1.  S $P(LRNGS,"^")=$P(LRY,"!")
  1.  F I=2:1:5,11,12 D
  1.  . ; enclose in quotes if not numeric
  1.  . I I<6,$P(LRY,"!",I)'?.N.1".".N S $P(LRY,"!",I)=$C(34)_$P(LRY,"!",I)_$C(34)
  1.  . S $P(LRNGS,"^",I)=$P(LRY,"!",I),$P(LRNG,"^",I)=$P(LRY,"!",I),@("LRNG"_I)=$P(LRY,"!",I)
  1.  S $P(LRNG,"^",7)=$P(LRY,"!",7),$P(LRNGS,"^",7)=$P(LRY,"!",7)
  1.  Q
  1.  ;
  1.  ;
  1. CKPLNR ; Check performing lab normal ranges and set abnormal flag
  1.  ; based on HL7 messages/interface.
  1.  S LRFLG=$P(LRSB(LRSB),"^",2)
  1.  I '$D(LRQ),$E(LRFLG,2)="*" D DISPFLG^LRVER4
  1.  Q
  1.  ;
  1.  ;
  1. SUBS D SUBS^LRVER4
  1.  Q
  1.  ;
  1.  ;
  1. WT D WT^LRVER4
  1.  Q
  1.  ;
  1.  ;
  1. COM ;from LRVR5
  1.  Q:$D(LRGVP)!('$D(LRLABKY))
  1.  D DCOM^LRVERA
  1.  K DR,DA,DIE
  1.  S DIE="^LR("_LRDFN_",""CH"",",DA=LRIDT,DA(1)=LRDFN,DR=.99 D ^DIE
  1.  Q
  1.  ;
  1.  ;
  1. LRSBCOM ;Display/store comments from the instrument
  1.  N LRSBCOM,LRI
  1.  S LRI=0
  1.  F  S LRI=$O(^LAH(LRLL,1,LRSQ,1,LRI)) Q:LRI=""  D
  1.  . S LRSBCOM=^LAH(LRLL,1,LRSQ,1,LRI)
  1.  . I $P(LRSBCOM,"^",2) Q  ; Already been processed
  1.  . D LRSBCOM1
  1.  . S $P(^LAH(LRLL,1,LRSQ,1,LRI),U,2)=1 ; Mark as processed
  1.  I $G(LRQUIET) Q
  1.  W !
  1.  S LRLCT=$G(LRLCT)+1 D:LRLCT>22 WT
  1.  Q
  1.  ;
  1.  ;
  1. LRSBCOM1 ; Store instrument comments in file #63
  1.  ; Check for duplicate comments in ^LAH and ^LR globals
  1.  N LRDUP,LRERR,LRI,LRNOECHO,LRNOEXPD,LRX,LRY
  1.  ;
  1.  ; Don't echo comments/don't expand comment using lab description file.
  1.  ; Used by LRNUM - called from input transform of #.01 field.
  1.  S LRNOECHO=0,LRNOEXPD=1
  1.  ;
  1.  ; Check for duplicates - comment stripped if spaces, force to upper case unless
  1.  ; flag set to store duplicates (Field #2.2 of PROFILE multiple in file #68.2)
  1.  S LRDUP=0
  1.  I '$P($G(^LRO(68.2,LRLL,10,+$G(LRPROF),0)),U,4) D
  1.  . S LRI=0,LRY=$TR(LRSBCOM," ",""),LRY=$$UP^XLFSTR(LRY)
  1.  . F  S LRI=$O(^LR(LRDFN,"CH",LRIDT,1,LRI)) Q:'LRI  D  Q:LRDUP
  1.  . . S LRX=$P($G(^LR(LRDFN,"CH",LRIDT,1,LRI,0)),U)
  1.  . . S LRX=$TR(LRX," ",""),LRX=$$UP^XLFSTR(LRX)
  1.  . . I LRX=LRY S LRDUP=1
  1.  I LRDUP=1 Q  ; Duplicate comment
  1.  D FILECOM(LRDFN,LRIDT,LRSBCOM)
  1.  I $G(LRQUIET) Q
  1.  W !,"Inst Comments: "_LRSBCOM
  1.  S LRLCT=$G(LRLCT)+1 D:LRLCT>10 WT
  1.  Q
  1.  ;
  1.  ;
  1. FILECOM(LRDFN,LRIDT,LRCMT) ; File comment in field #99
  1.  ; Call with LRDFN = ien of patient in file #63
  1.  ;           LRIDT = ien of specimen date/time
  1.  ;           LRCMT = comment to store
  1.  ;
  1.  N LRFDA,LRERR
  1.  S LRFDA(2,63.041,"+2,"_LRIDT_","_LRDFN_",",.01)=LRCMT
  1.  D UPDATE^DIE("","LRFDA(2)","","LRERR(2)")
  1.  Q