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

LRWLST11.m

Go to the documentation of this file. 
  1. LRWLST11 ;DALOI/STAFF - ACCESSION SETUP ;Mar 27, 2008
  1.  ;;5.2;LAB SERVICE;**121,128,153,202,286,331,375,350,440,461**;Sep 27, 1994;Build 15
  1.  ;
  1. ST21 ;
  1.  S LRTS="",LRIX=0
  1.  F  S LRIX=$O(LRTSTS(LRWLC,LRUNQ,LRAA,LRIX)) Q:LRIX<1  D SET Q:LRUNQ
  1.  ;
  1.  S LRNT=$$NOW^XLFDT
  1.  D SCDT,SLRSS
  1.  ;
  1. COMMON ; Setup 'in common' accession if not already setup unless it will be 
  1.  ; when tests are accessioned to the 'in common' area.
  1.  I +LRWLC,+LRWLC'=+LRAA,$G(^LRO(68,LRWLC,1,LRAD,1,LRAN,0))=$G(LRDFN) D
  1.  . I 'LRUNQ,$D(LRTSTS(LRWLC,LRUNQ,LRWLC)) Q
  1.  . Q:$G(^LRO(68,LRWLC,1,LRAD,1,LRAN,.1))
  1.  . N LRAA,LRACC,LRCDTX,LRCOMMON,LREND,LRIDT,LRNODE3,LRORDRR,LRORU3,LRQUIET,LRTJ,LRUID,X,Y
  1.  . S (LRQUIET,LRCOMMON)=1,LRAA=+LRWLC,LRORDRR=""
  1.  . S X=LRSS,LRCDTX=LRCDT
  1.  . N LRCDT,LRSS
  1.  . S LRCDT=LRCDTX,LRSS=X_U_(1+$G(LRLBLBP))
  1.  . D STWLN^LRWLST1 Q:$G(LREND)
  1.  . D ST2^LRWLST1 Q:$G(LREND)
  1.  . D SCDT,SLRSS
  1.  ;
  1.  Q
  1.  ;
  1.  ;
  1. SCDT ; Set collection, inverse and lab arrival date/times on accession
  1.  N FDA,LR6802,LRDIE
  1.  S LR6802=LRAN_","_LRAD_","_LRAA_","
  1.  S FDA(4,68.02,LR6802,9)=LRCDT
  1.  S FDA(4,68.02,LR6802,10)=LREAL
  1.  I '$D(LRPHSET) S FDA(4,68.02,LR6802,12)=LRNT
  1.  S FDA(4,68.02,LR6802,13.5)=LRIDT
  1.  D FILE^DIE("","FDA(4)","LRDIE(4)")
  1.  I $D(LRDIE(4)) D MAILALRT^LRWLST12("SCDT~LRWLST11")
  1.  Q
  1.  ;
  1.  ;
  1. SLRSS ;
  1.  ;
  1.  N FDA,FDAIEN,LRDIE,LRX
  1.  S LRX=$S(LRSS="CH":63.04,LRSS="MI":63.05,LRSS="SP":63.08,LRSS="CY":63.09,LRSS="EM":63.02,LRSS="BB":63.01,1:0)
  1.  S X=$G(^LRO(68,LRAA,1,LRAD,1,LRAN,5,1,0)) ; change for AP
  1.  S H8=$S($D(LRSPEC):LRSPEC,1:X)_U_$S("CYEMSPAU"[LRSS:LRACC,1:LRACC)_U_$S(LRSS="MI":LRPRAC,1:"")_U_$S(LRSS="MI":LRLLOC,1:"")_"^^"_$S(LRSS="CH":LRPRAC,1:LRNT)_"^"_$S(LRSS="MI":$P(LRSAMP,";",1),LRSS="CH":LRLLOC,1:"")
  1.  ;
  1.  I $S(LRSS="CH":1,LRSS="MI":1,1:0) D
  1.  . I $G(LRORDRR)="R",+$G(LRRSITE("RSITE")) S $P(H8,U,9)=+LRRSITE("RSITE")_";DIC(4,"
  1.  . I $G(LROLLOC),$G(LRORDRR)'="R" S $P(H8,U,9)=LROLLOC_";SC("
  1.  . S $P(H8,U,10)=$S($G(LRDUZ(2)):LRDUZ(2),1:$G(DUZ(2)))
  1.  ;
  1.  D SLRSS^LRWLST1A
  1.  ;allow labels to print for Anatomic Pathology accessions
  1.  ;by commenting out the line below
  1.  ;(The two lines below that were already commented out.)
  1.  ;Q:"SPEMCY"[LRSS
  1.  ;S ^LR(LRDFN,LRSS,LRIDT,0)=LRCDT_U_LREAL_"^^^"_H8
  1.  ;I $G(LRORU3)'="" S ^LR(LRDFN,LRSS,LRIDT,"ORU")=LRORU3
  1.  ;
  1. ST3 ;
  1.  I LRSS="MI" D ST4
  1.  D LRCCOM
  1.  ;
  1.  S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3),LRPR=1
  1.  S LRRB=0
  1.  I LRDPF=2 S LRRB=$$GET1^DIQ(2,DFN_",",.101),LRRB=$S(LRRB'="":LRRB,1:0)
  1.  ;
  1.  Q:$G(LRORDR)="P"
  1.  ;
  1.  I '$D(LRTJ) D  Q
  1.  . I $G(LRORDRR)="R",LRSS="CH",$G(LRORU3)'="",$P(LRORU3,"^")'=$P(LRORU3,"^",4) Q  ; Don't print, use label from sending facility.
  1.  . I $G(LRLBLBP),'$G(LRCOMMON) S LRLBL(LRAA,LRAN)=LRSN_U_LRAD_U_LRODT_U_LRRB_U_LRLLOC_U_LRACC_U_$S($D(LRORD):LRORD,1:"")
  1.  ;Anatomic Pathology labels do not print on collection lists
  1.  Q:"SPEMCY"[LRSS
  1.  S I=0
  1.  F  S I=$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,I)) Q:I<.5  S LRTS=^(I,0) D Z
  1.  ;
  1.  Q
  1.  ;
  1.  ;
  1. ST4 ;
  1.  ;S $P(^LR(LRDFN,LRSS,LRIDT,0),U,10)=$S($D(LRNT):LRNT,1:""),$P(^(0),U,8)=LRLLOC
  1.  ; Used to be LRSPCDSC,63.05,.9 (Word Processing field) replaces 63.05,.99
  1.  S:$D(LRCCOM) ^LR(LRDFN,LRSS,LRIDT,99)=LRCCOM
  1.  I '$D(LRPHSET) D
  1.  . N DA,DIE,DR
  1.  . S DIE="^LR("_LRDFN_",""MI"",",DA=LRIDT,DA(1)=LRDFN
  1.  . ;S DR=.9
  1.  . ;I '$G(LRQUIET) W:DR'=.9 !!,"Order comment:"
  1.  . S DR=.99_$S($L($G(LRGCOM)):"///"_LRGCOM,$L($G(LRCCOM)):"//"_LRCCOM,1:"")
  1.  . I '$G(LRQUIET) W:DR'=.99 !!,"Order comment:"
  1.  . D ^DIE
  1.  I '$G(LRQUIET),'$D(LRPHSET),'$D(LRGCOM) W !,"Description OK? Y//" D % G ST4:%["N"
  1.  K DR,DIC,DIE
  1.  Q
  1.  ;
  1.  ;
  1. ST5 S I("SUBSC")=$S(I("EDIT")[11.5:26,I("EDIT")[15:27,I("EDIT")[19:28,I("EDIT")[23:29,I("EDIT")[34:30,1:-1) Q:I("SUBSC")=-1
  1.  S I("PNTR")=$S(I("EDIT")[11.5:"^63.061A^",I("EDIT")[15:"^63.361A^",I("EDIT")[19:"^63.111A^",I("EDIT")[23:"^63.181A^",1:"^63.432A^")
  1.  S I("N")=1+$S($D(^LR(LRDFN,"MI",LRIDT,I("SUBSC"),0)):$P(^(0),U,4),1:0),^(0)=I("PNTR")_I("N")_U_I("N"),^(I("N"),0)=I("TEST")
  1.  Q
  1.  ;
  1.  ;
  1. SET ;
  1.  S LRTS=LRTSTS(LRWLC,LRUNQ,LRAA,LRIX)
  1.  S LRIN=$P(LRTS,U,3),LRORIFN=$P(LRTS,U,4),LRTSORU=+$P(LRTS,U,6),LRBACK=$P(LRTS,U,5),LRTS=$P(LRTS,U,1,2)
  1.  ;
  1.  I '$G(LRQUIET),'$D(LRPHSET) D
  1.  . W !,$P(^LAB(60,+LRTS,0),U)
  1.  . I $D(LRSPEC),LRSPEC D
  1.  . . S I=$S($D(^LAB(61,+LRSPEC,0)):$P(^(0),U),1:""),J=$S($D(^LAB(62,+LRSAMP,0)):$P(^(0),U),1:"")
  1.  . . W ?30,J W:I'=J "  ",I
  1.  ;
  1.  I '$G(LRQUIET),'$D(LRPHSET),+LRTS,$O(^LAB(60,+LRTS,7,0))>0 D
  1.  . N S
  1.  . S DIC="^LAB(60,",DA=+LRTS,DR=7
  1.  . D EN^DIQ H 3
  1.  I '$G(LRQUIET),'$D(LRPHSET),+LRTS D
  1.  . N S
  1.  . S DIC="^LAB(60,"_(+LRTS)_",3,"
  1.  . S DA=+$O(^LAB(60,+LRTS,3,"B",+LRSAMP,0)),DR=2
  1.  . I DA>0,$O(^LAB(60,+LRTS,3,DA,2,0))>0 D EN^DIQ H 3
  1.  ;
  1.  D ORUT
  1.  ;
  1.  ; Check if LEDI specimen being accessioned then
  1.  ;  -  update test status of order in file #69.6
  1.  ;  -  if LEDI AP specimen copy data accompanying order from file #69.6 to file #63
  1.  ;  -  update remote ordering provider from file #69.6 to ordered test multiple (#.35)
  1.  I $G(LRORDRR)="R",$G(LR696)>0 D
  1.  . D ORUT2^LRWLST12
  1.  . D PROVCPY^LRWLST12
  1.  . I "SPCYEM"[LRSS D APMOVE^LRWLST12
  1.  ;
  1.  D CAP^LRWLST12
  1.  K LRTSTS(LRWLC,LRUNQ,LRAA,LRIX)
  1.  ;
  1.  S ^LRO(69,LRODT,1,LRSN,2,LRIN,0)=LRTS_U_LRAD_U_LRAA_U_LRAN_"^^"_LRORIFN_"^^IP^L^^^^"_LRBACK
  1.  S ^LRO(69,LRODT,1,LRSN,2,"B",+LRTS,LRIN)=""
  1.  ;
  1.  ; When file 63 is enhanced to accept comments per test comments should
  1.  ; be put there instead of field 99.
  1.  I $O(^LRO(69,LRODT,1,LRSN,2,LRIN,1,0)) D
  1.  . I LRSS'="CH"!($D(^LR(LRDFN,LRSS,LRIDT,0))[0) Q
  1.  . S X=$S($D(^LR(LRDFN,LRSS,LRIDT,1,0)):$P(^(0),"^",3),1:0),I=0
  1.  . F  S I=$O(^LRO(69,LRODT,1,LRSN,2,LRIN,1,I)) Q:I<1  S II=^(I,0) S X=X+1,^LR(LRDFN,LRSS,LRIDT,1,X,0)=II
  1.  . S:X ^LR(LRDFN,LRSS,LRIDT,1,0)="^63.041^"_X_U_X
  1.  ;
  1. RUID I $G(LRORU3)'="" D
  1.  . N DA,DIE,DIC,DLAYGO,DR,X,Y
  1.  . S DLAYGO=69
  1.  . S DA=LRIN,DA(1)=LRSN,DA(2)=LRODT,DIC="^LRO(69,"_DA(2)_",1,"_DA(1)_",2,"
  1.  . S DIE=DIC,DR="13////"_$P(LRORU3,U)_";14////"_$P(LRORU3,U,2)_";15////"_$P(LRORU3,U,3)_";16////"_$P(LRORU3,U,4)_";17////"_$P(LRORU3,U,5)
  1.  . D ^DIE
  1.  Q
  1.  ;
  1.  ;
  1. % R %:DTIME Q:%=""!(%["N")!(%["Y")  W !,"Answer 'Y' or 'N': " G %
  1.  ;
  1.  ;
  1. LRCCOM ; Copy comments from file #69 to file #63 comment multiple
  1.  N I,LRCCOM,LRTN,X
  1.  S (I,LRTN,LRCCOM)=0
  1.  ;
  1.  I LRSS'="CH"!($D(^LR(LRDFN,LRSS,LRIDT,0))[0) Q
  1.  ;
  1.  ; Copy (#16) WARD COMMENTS ON SPECIMEN to file #63 comment multiple
  1.  F  S I=$O(^LRO(69,LRODT,1,LRSN,6,I)) Q:I<1  I $D(^(I,0)) S X=^(0),LRCCOM=LRCCOM+1,^LR(LRDFN,LRSS,LRIDT,1,LRCCOM,0)=X
  1.  ;
  1.  ; Copy expanded panels (#99) TEST COMMENTS to file #63 comment multiple
  1.  F  S LRTN=$O(^LRO(69,LRODT,1,LRSN,2,LRTN)) Q:'LRTN  I $D(^(LRTN,0)) S X=^(0) I $P(X,"^",8),'$P(X,"^",3),$O(^(1,0)) D
  1.  . S I=0
  1.  . F  S I=$O(^LRO(69,LRODT,1,LRSN,2,LRTN,1,I)) Q:'I  I $D(^(I,0)) S X=^(0),LRCCOM=LRCCOM+1,^LR(LRDFN,LRSS,LRIDT,1,LRCCOM,0)=X
  1.  ;
  1.  S:LRCCOM ^LR(LRDFN,LRSS,LRIDT,1,0)="^63.041^"_LRCCOM_U_LRCCOM
  1.  ;
  1.  Q
  1.  ;
  1.  ;
  1. Z ; Update collection list (#69.1)
  1.  L +^LRO(69.1,LRTE):999
  1.  S LRZ3=$S($D(^LRO(69.1,LRTE,1,0)):$P(^(0),U,3),1:0)
  1.  ;
  1. Z1 S LRZ3=LRZ3+1 G:$D(^LRO(69.1,LRTE,1,LRZ3)) Z1
  1.  S LRZO="^LRO(69.1,"_LRTE_",1,",LRZ1="69.11P",LRZB=+LRTS,LRIFN=LRZ3
  1.  D Z^LRWU
  1.  S ^LRO(69.1,LRTE,1,LRIFN,0)=+LRTS_"^"_LRLLOC_"^"_LRRB_"^"_LRDFN_"^"_LRSN_"^"_LRTJ_"^"_LRAD_"^"_LRAA_"^"_LRAN_"^"_+LROLLOC
  1.  S ^LRO(69.1,"LRPH",LRTE,LRLLOC,LRRB,LRDFN,LRSN)=LRTJ_"^"_LRAD_"^"_LRIFN,^(LRSN,LRAA,LRAN,+LRTS)=+LRTS
  1.  L -^LRO(69.1,LRTE)
  1.  Q
  1.  ;
  1.  ;
  1. ORUT ;Set ORUT/ordered test node in file 63
  1.  ;LRSS=subscript-required
  1.  ;LRIDT=inverse date-required
  1.  ;LRDFN=IEN file 63-required
  1.  ;LRTSORU=ordered test (file #60 IEN)-required
  1.  ;LRURG=ordered urgency
  1.  ;LRORIFN=CPRS order #
  1.  ;LRORNUM=Lab order # LR_XXXX where XXXX is a julian date
  1.  ;LRORTYP=ordered type
  1.  ;LRPROVL=ordering provider local
  1.  ;LRSPEC=specimen topography
  1.  ;LRSAMP=Collection sample
  1.  ;
  1.  N LRFDA,LRFILE,LRIEN,LRIENS,LRJUL,LRMSG,LRNLT,LRORNUM,LRORTYP
  1.  N LRPROVL,LRX,LRY,DIERR
  1.  S LRFILE=$S(LRSS="CH":63.07,LRSS="MI":63.5,LRSS="SP":63.53,LRSS="CY":63.51,LRSS="EM":63.52,1:"")
  1.  Q:'LRFILE!('$G(LRTSORU))
  1.  ;
  1.  S LRNLT=$$NLT^LRVER1(+LRTSORU) Q:+LRNLT<1
  1.  S LRORTYP=""
  1.  I $P($G(LRORDTYP),"^",2) S LRORTYP=$P(LRORDTYP,"^",2)
  1.  I LRORTYP="" D
  1.  . I $G(LRORDR)'="" S LRX=$S($G(LRORDR)="WC":"O",1:"L")
  1.  . I $G(LRORDR)="" S LRX=$S($G(LRORDRR)="R":"O",$G(LRLWC)="WC":"O",1:"L")
  1.  . S LRORTYP=$$FIND1^DIC(64.061,"","OX",LRX,"D","I $P(^(0),U,5)=""0065""")
  1.  S LRPROVL=$S($G(LRPRAC)?1.N:LRPRAC,1:"")
  1.  I $G(LRORD) D
  1.  . S LRX=$$FMDIFF^XLFDT(DT,$E(DT,1,3)_"0101",1)
  1.  . S LRX=LRX+1,LRJUL=$E("000",1,3-$L(LRX))_LRX
  1.  . S LRORNUM="LR-"_LRORD_"-"_$E(DT,1,3)_LRJUL
  1.  ;
  1.  S LRIEN="?+1"_","_LRIDT_","_LRDFN_","
  1.  S LRFDA(5,LRFILE,LRIEN,.01)=LRNLT
  1.  I $G(LRURG) S LRFDA(5,LRFILE,LRIEN,2)=LRURG
  1.  I $G(LRORIFN) S LRFDA(5,LRFILE,LRIEN,3)=LRORIFN
  1.  I $G(LRORNUM)'="" S LRFDA(5,LRFILE,LRIEN,4)=LRORNUM
  1.  I LRORTYP'="" S LRFDA(5,LRFILE,LRIEN,5)=LRORTYP
  1.  I LRPROVL'="" S LRFDA(5,LRFILE,LRIEN,6)=LRPROVL
  1.  I $G(LRSPEC) S LRFDA(5,LRFILE,LRIEN,8)=LRSPEC
  1.  I $G(LRSAMP) S LRFDA(5,LRFILE,LRIEN,9)=LRSAMP
  1.  I +LRTSORU S LRFDA(5,LRFILE,LRIEN,13)=+LRTSORU
  1.  I $P($G(LRORDTYP),"^",3) D
  1.  . S LRFDA(5,LRFILE,LRIEN,14)=$P(LRORDTYP,"^",3)
  1.  . S LRFDA(5,LRFILE,LRIEN,15)=$P(LRORDTYP,"^",4)
  1.  D UPDATE^DIE("","LRFDA(5)","LRIENS","LRMSG")
  1.  D CLEAN^DILF
  1.  ;
  1.  Q
  1.  ;
  1.  ;
  1. SICA ; Check accessions 'in common' and setup reference to this accession
  1.  N FDA,LR6802,LRDIE,LRAA
  1.  S LRX=$P($G(^LRO(68,LRWLC,1,LRAD,1,LRAN,.2)),"^"),LRAA=0
  1.  F  S LRAA=$O(LRTSTS(LRWLC,LRUNQ,LRAA)) Q:LRAA<1  I LRWLC'=LRAA D
  1.  . I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) Q
  1.  . K FDA,LRDIE
  1.  . S LR6802=LRAN_","_LRAD_","_LRAA_","
  1.  . S FDA(5,68.02,LR6802,15.1)=LRX
  1.  . D FILE^DIE("","FDA(5)","LRDIE(5)")
  1.  . I $D(LRDIE(5)) D MAILALRT^LRWLST12("SICA~LRWLST11")
  1.  Q