LRRPLU ;DALOI/JMC - Lab Report Performing Lab Utility ;02/22/13 10:11
;;5.2;LAB SERVICE;**350,427**;Sep 27, 1994;Build 33
;
Q
;
;
EDIT(LRDFN,LRSS,LRIDT) ; Add/edit performing lab for a section of a report
; Call with LRDFN = File #63 IEN
; LRSS = File #63 subscript
; LRIDT = File #63 inverse date/time of specimen
;
;
N DIR,DIROUT,DIRUT,DUOUT,LRHLP,LRLST,LRPL,LRX,LRY,X,Y
; Autospy does not have an inverse date/time
I LRSS="AU" S LRIDT=0
I LRSS="MI",'($$GET^XPAR("ALL","LR ASK PERFORMING LAB MICRO",1,"Q")) D NOASK^LRRPLUA Q
I LRSS?1(1"SP",1"CY",1"EM"),'($$GET^XPAR("ALL","LR ASK PERFORMING LAB AP",1,"Q")) D NOASK^LRRPLUA Q
F D Q:$D(DIRUT)
. K LRPL,LRLST
. D RETLST^LRRPL(.LRPL,LRDFN,LRSS,LRIDT,2)
. ;
. I $D(LRPL(0)) D
. . M LRLST=LRPL(0) K LRPL(0)
. . S LRPL(.5)="Current performing lab assignments:",LRPL(.6)=" "
. E S LRPL(.5)="Current performing lab assignments: None Listed"
. D EN^DDIOL(.LRPL)
. ;
. K DIR,LRHLP
. S DIR(0)="SO^1:Entire report;2:Specific sections of report"
. I $D(LRLST) S DIR(0)=DIR(0)_";3:Delete performing laboratory"
. E S DIR("B")=1
. S DIR("A")="Designate performing laboratory for"
. I $G(DIR("B"))'="" S DIR("?")="Enter a code from the list or '^' to exit."
. E S DIR("?")="Enter a code from the list or <ENTER> to exit."
. M LRHLP=LRPL
. S X=$G(LRPL),LRHLP(X+1)=" ",LRHLP(X+2)=DIR("?")
. S DIR("??")="^D EN^DDIOL(.LRHLP)"
. D ^DIR
. I $D(DIRUT) Q
. I Y=1 D SET1(0) Q
. I Y=2 D SET2 Q
. I Y=3 D DEL Q
;
Q
;
;
SET1(LRSECT) ; Set performing lab for entire or major section of report.
; Update if already set otherwise create a new record.
; Call with LRSECT = section of report
;
N DIR,DIROUT,DIRUT,DUOUT,LRDIE,LRDPL,LRFDA,LRFLAG,LRIEN,LRREF,LRPLAB
S LRFLAG=0
I LRSS?1(1"MI",1"SP",1"CY",1"EM") S LRFLAG=1
S LRDPL=$$GET^XPAR("USR","LR VER DEFAULT PERFORMING LAB",1,"Q")
I LRDPL<1 S LRDPL=DUZ(2)
S LRPLAB=$$SELPL^LRVERA(LRDPL,LRFLAG)
I LRPLAB<1 Q
S LRREF=LRDFN_","_LRSS_","_LRIDT_","_LRSECT
;
; Confirm that user wants to add/update record.
W !
S DIR(0)="YO",DIR("B")="NO"
S DIR("A")="Sure you want to "_$S($D(^LR(LRDFN,"PL","B",LRREF)):"update",1:"add")_" this record"
D ^DIR
I Y'=1 Q
;
; Update existing entry
I $D(^LR(LRDFN,"PL","B",LRREF)) D Q
. D UEE(LRDFN,LRREF,LRPLAB)
. W !,"... assignment updated.",!
;
; Create new entry
D CNE(LRDFN,LRREF,LRPLAB)
W !,"... assignment created.",!
;
Q
;
;
SET2 ; Set performing lab for specific section of report
;
N DIR,DIROUT,DIRUT,DUOUT,I,LRCNT,LRI,LRPLIEN,LRQUIT,LRREC,LRREF,LRROOT,LRSEC,LRSECT,LRX,LRY
; Find the current existing sections of the report
S LRREF="",(LRI,LRQUIT,LRREC)=0
S (LRROOT,LRX)=LRDFN_","_LRSS_","_LRIDT_","
F S LRX=$O(^LR(LRDFN,"PL","B",LRX)) Q:LRX="" D Q:LRQUIT
. I $P(LRROOT,",",1,3)'=$P(LRX,",",1,3) S LRQUIT=1 Q
. S LRPLIEN=$O(^LR(LRDFN,"PL","B",LRX,0))
. S LRI=$P(LRX,",",4,99),LRY="LRSEC("_LRDFN_",LRSS,"_LRIDT_",LRI)"
. S @LRY=LRX_"^"_LRPLIEN
;
I LRSS="MI" D MICHK
I LRSS?1(1"SP",1"CY",1"EM") D APCHK
I LRSS="AU" D AUCHK
;
W !
I $G(LRREC)<1 D Q
. S DIR(0)="E",DIR("A",1)="NO sections to designate.",DIR("A")="Press any key to continue"
. D ^DIR
;
S LRCNT=$O(LRREC(""),-1)
F I=1:1:LRCNT S DIR("A",I)=$J(I,11)_" - "_$P(LRREC(I),"^")
S DIR("A")="Select the section to designate (1-"_LRCNT_"): "
S DIR(0)="NOA^1:"_LRCNT_":0"
S DIR("??")="^D EN^DDIOL(.LRPL)"
D ^DIR
I $D(DIRUT) Q
;
S LRSECT=$P(LRREC(Y),"^",2)
;
I LRSS="MI" D
. S LRX="1^^^^1^^^1^^^1^^^^^1^^^^^^^^^^^^^^^1^"
. I $P(LRX,"^",LRSECT)!(LRSECT=99) D SET1(LRSECT) Q
. ;
. S LRX="^1^1^1^^1^1^^1^1^^1^1^1^1^^1^1^1^1^1^1^1^1^1^1^1^1^1^1^"
. I $P(LRX,"^",LRSECT) D
. . N LRY
. . D GETMULTI
. . W ! S LRX=$$SELMULTI(.LRY)
. . I LRX#1=.1 W ! K LRY D MIAB(.LRY,$P(LRX,",",5)) S LRX=$$SELMULTI(.LRY)
. . S LRREF=$P(LRX,"^",3)
. . I LRREF'="" D SETREF
;
I LRSS?1(1"SP",1"CY",1"EM") D
. I LRSECT=1.2!(LRSECT=97)!(LRSECT=99) D Q
. . N LRY
. . D GETMULTI
. . W ! S LRX=$$SELMULTI(.LRY),LRREF=$P(LRX,"^",3)
. . I LRREF'="" D SETREF
. I LRSECT=2 D Q
. . N LRY
. . D GETMULTI
. . W ! S LRX=$$SELMULTI(.LRY)
. . I LRX#1=.1 W ! K LRY D APSS(.LRY,$P(LRX,",",5)) S LRX=$$SELMULTI(.LRY)
. . S LRREF=$P(LRX,"^",3)
. . I LRREF'="" D SETREF
. D SET1(LRSECT)
;
I LRSS="AU" D
. I LRSECT=84!(LRSECT="AZC") D Q
. . N LRY
. . D GETMULTI
. . W ! S LRX=$$SELMULTI(.LRY),LRREF=$P(LRX,"^",3)
. . I LRREF'="" D SETREF
. I LRSECT="AY" D Q
. . N LRY
. . D GETMULTI
. . W ! S LRX=$$SELMULTI(.LRY)
. . I LRX#1=.1 W ! K LRY D APSS(.LRY,$P(LRX,",",3)) S LRX=$$SELMULTI(.LRY)
. . S LRREF=$P(LRX,"^",3)
. . I LRREF'="" D SETREF
. D SET1(LRSECT)
;
Q
;
;
SETREF ; Set reference to performing lab in file #63
; Update if already set otherwise create a new record.
;
; Confirm that user wants to add/update record.
N DIR,DIROUT,DIRUT,DUOUT,LRDIE,LRDPL,LRFDA,LRFLAG,LRIEN,LRPLAB
;
S LRFLAG=0
I LRSS?1(1"MI",1"SP",1"CY",1"EM",1"AU") S LRFLAG=1
S LRDPL=$$GET^XPAR("USR","LR VER DEFAULT PERFORMING LAB",1,"Q")
I LRDPL<1 S LRDPL=DUZ(2)
S LRPLAB=$$SELPL^LRVERA(LRDPL,LRFLAG)
I LRPLAB<1 Q
;
W !
K DIR
S DIR(0)="YO",DIR("B")="NO"
S DIR("A")="Sure you want to "_$S($D(^LR(LRDFN,"PL","B",LRREF)):"update",1:"add")_" this record"
D ^DIR
I Y'=1 Q
;
; Update existing entry
I $D(^LR(LRDFN,"PL","B",LRREF)) D Q
. D UEE(LRDFN,LRREF,LRPLAB)
. W !,"... assignment updated.",!
;
; Create new entry
D CNE(LRDFN,LRREF,LRPLAB)
W !,"... assignment created.",!
;
Q
;
;
DEL ; Delete existing performing laboratory designations.
;
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,LRCNT,LRFDA,LRIEN,X,Y
S LRCNT=$O(LRLST(""),-1)
;
W !
I LRCNT=1 S Y=1
I LRCNT>1 D Q:$D(DIRUT)
. S DIR("A")="Select the section to delete (1-"_LRCNT_"): "
. F I=1:1:LRCNT S DIR("A",I)=$J(I,11)_" - "_$P(LRLST(I),"^",3)
. S DIR(0)="NOA^1:"_LRCNT_":0"
. D ^DIR
;
S LRIEN=$P(LRLST(Y),"^",2)
;
; Confirm that user wants to delete record.
K DIR
S DIR(0)="YO",DIR("B")="NO"
S DIR("A")="Sure you want to delete this performing lab assignment"
D ^DIR
I Y'=1 W !,"... deletion cancelled.",! Q
;
; Delete existing entry
D DEE(LRIEN_","_LRDFN_",")
;
I '$D(^LR(LRDFN,"PL",LRIEN)) W !,"... assignment deleted.",!
E W "... assignment NOT deleted.",!
;
Q
;
;
UEE(LRDFN,LRREF,LRPLAB) ; Update existing entry
; Call with LRDFN = File #63 IEN
; LRREF = File #63 subscript reference
; LRPLAB = Performing lab as IEN in file #4
;
N LRDIE,LRFDA,LRIEN
S LRIEN=$O(^LR(LRDFN,"PL","B",LRREF,0))
S LRFDA(1,63.00012,LRIEN_","_LRDFN_",",.02)=LRPLAB
D FILE^DIE("","LRFDA(1)","LRDIE(1)")
Q
;
;
CNE(LRDFN,LRREF,LRPLAB) ; Create new entry
; Call with LRDFN = File #63 IEN
; LRREF = File #63 subscript reference
; LRPLAB = Performing lab as IEN in file #4
;
N LRDIE,LRFDA,LRIEN
S LRFDA(1,63.00012,"+1,"_LRDFN_",",.01)=LRREF
S LRFDA(1,63.00012,"+1,"_LRDFN_",",.02)=LRPLAB
D UPDATE^DIE("","LRFDA(1)","LRIEN","LRDIE(1)")
Q
;
;
DEE(LRIENS) ; Delete existing entry
; Call with LRRIENS = File #63 performing lab reference IENS
;
N LRDIE,LRFDA
S LRFDA(1,63.00012,LRIENS,.01)="@"
D FILE^DIE("","LRFDA(1)","LRDIE(1)")
Q
;
;
MICHK ; Check MI for sections to link to a performing lab
;
N I,LRI
;
; Bacteriology section
S LRI=1
I $D(^LR(LRDFN,LRSS,LRIDT,LRI)) D
. D MICHK1
. N LRJ
. F LRJ=5,6 I $P(^LR(LRDFN,LRSS,LRIDT,LRI),"^",LRJ)'="" D
. . S LRREF=LRROOT_LRI_";"_LRJ,LRREC=LRREC+1 D MICHK^LRRPL S $P(LRREC(LRREC),"^",2)=LRI_";"_LRJ
. . S LRREC(LRREC,0)=$G(LRSEC(LRDFN,LRSS,LRIDT,LRI_";"_LRJ))
;
; Gram stain/Organism/Susceptibility/Remark section
F LRI=2,3,4 I $O(^LR(LRDFN,LRSS,LRIDT,LRI,0)) D
. D MICHK2
. I LRI=3 D BUGCHK
;
; Parasite section - check for parasite and stage info
S LRI=5
I $D(^LR(LRDFN,LRSS,LRIDT,LRI)) D MICHK1
;
F LRI=6,7 I $O(^LR(LRDFN,LRSS,LRIDT,LRI,0)) D
. D MICHK2
. I LRI=6 D BUGCHK
;
; Mycology section
S LRI=8
I $D(^LR(LRDFN,LRSS,LRIDT,LRI)) D MICHK1
;
F LRI=9,10,15 I $O(^LR(LRDFN,LRSS,LRIDT,LRI,0)) D
. D MICHK2
. I LRI=9 D BUGCHK
;
; Mycobacteria section - also check for AFB stain
S LRI=11
I $D(^LR(LRDFN,LRSS,LRIDT,LRI)) D
. D MICHK1
. I $P(^LR(LRDFN,LRSS,LRIDT,LRI),"^",3)'="" D
. . S LRREF=LRROOT_LRI_";3",LRREC=LRREC+1 D MICHK^LRRPL S $P(LRREC(LRREC),"^",2)=LRI_";3"
. . S LRREC(LRREC,0)=$G(LRSEC(LRDFN,LRSS,LRIDT,LRI_";3"))
;
; TB/Organism/Susceptibilityr/Remark section
F LRI=12,13,14 I $O(^LR(LRDFN,LRSS,LRIDT,LRI,0)) D
. D MICHK2
. I LRI=12 D BUGCHK
;
; Virology section
S LRI=16
I $D(^LR(LRDFN,LRSS,LRIDT,LRI)) D MICHK1
;
F LRI=17,18 I $O(^LR(LRDFN,LRSS,LRIDT,LRI,0)) D
. D MICHK2
. I LRI=17 D BUGCHK
;
; Various preliminary comment sections
F LRI=19:1:30 I $O(^LR(LRDFN,LRSS,LRIDT,LRI,0)) D MICHK2
;
; Sterility Results
S LRI=31
I $D(^LR(LRDFN,LRSS,LRIDT,LRI)) D MICHK1
;
; Comment on Specimen
S LRI=99
I $D(^LR(LRDFN,LRSS,LRIDT,LRI)) D MICHK1
;
Q
;
;
MICHK1 ; Common MI checking logic
;
S LRREF=LRROOT_LRI,LRREC=LRREC+1 D MICHK^LRRPL S $P(LRREC(LRREC),"^",2)=LRI
S LRREC(LRREC,0)=$G(LRSEC(LRDFN,LRSS,LRIDT,LRI))
Q
;
;
MICHK2 ; Common MI checking logic
;
S LRREF=LRROOT_LRI_",0",LRREC=LRREC+1 D MICHK^LRRPL S $P(LRREC(LRREC),"^",2)=LRI
S LRREC(LRREC,0)=$G(LRSEC(LRDFN,LRSS,LRIDT,LRI,0))
Q
;
;
APCHK ; Check AP for sections to link to a performing lab
;
N LRI
;
F LRI=.2,.3,.4,.5,1,1.1,1.3,1.4 D
. I LRI=1.3,LRSS'="SP" Q
. I '$O(^LR(LRDFN,LRSS,LRIDT,LRI,0)) Q
. S LRREF=LRROOT_LRI_",0",LRREC=LRREC+1 D APCHK^LRRPL S $P(LRREC(LRREC),"^",2)=LRI
. S LRREC(LRREC,0)=$G(LRSEC(LRDFN,LRSS,LRIDT,LRI))
;
; Supplementary Report section (1.2)
S LRI=1.2
I $D(^LR(LRDFN,LRSS,LRIDT,LRI)) D
. S LRREF=LRROOT_LRI_",0",LRREC=LRREC+1 D APCHK^LRRPL S $P(LRREC(LRREC),"^",2)=LRI
. S LRREC(LRREC,0)=$G(LRSEC(LRDFN,LRSS,LRIDT,LRI))
;
; Special studies (2)
S LRI=2
I $D(^LR(LRDFN,LRSS,LRIDT,LRI)) D
. N LRJ
. S LRJ=0
. F S LRJ=$O(^LR(LRDFN,LRSS,LRIDT,LRI,LRJ)) Q:'LRJ I $O(^LR(LRDFN,LRSS,LRIDT,LRI,LRJ,5,0)) D Q
. . S LRREF=LRROOT_LRI_",0",LRREC=LRREC+1 D APCHK^LRRPL S $P(LRREC(LRREC),"^",2)=LRI
. . S LRREC(LRREC,0)=$G(LRSEC(LRDFN,LRSS,LRIDT,LRI))
;
; Delayed Report Comment (97) / Comment on Specimen (99)
F LRI=97,99 I $D(^LR(LRDFN,LRSS,LRIDT,LRI)) D
. S LRREF=LRROOT_LRI,LRREC=LRREC+1 D APCHK^LRRPL S $P(LRREC(LRREC),"^",2)=LRI
. S LRREC(LRREC,0)=$G(LRSEC(LRDFN,LRSS,LRIDT,LRI))
;
Q
;
;
AUCHK ; Check AU for sections to link to a performing lab
;
N LRI
;
; Clinical Diagnoses (81) / Pathological Diagnoses (82)
F LRI=81,82 D
. I '$O(^LR(LRDFN,LRI,0)) Q
. S LRREF=LRROOT_LRI,LRREC=LRREC+1 D AUCHK^LRRPL S $P(LRREC(LRREC),"^",2)=LRI
. S LRREC(LRREC,0)=$G(LRSEC(LRDFN,LRI))
;
; Supplementary Report section (84)
S LRI=84
I $D(^LR(LRDFN,LRI)) D
. S LRREF=LRROOT_LRI_",0",LRREC=LRREC+1 D AUCHK^LRRPL S $P(LRREC(LRREC),"^",2)=LRI
. S LRREC(LRREC,0)=$G(LRSEC(LRDFN,LRI))
.
; Special studies (AY)
S LRI="AY"
I $D(^LR(LRDFN,LRI)) D
. N LRJ
. S LRJ=0
. F S LRJ=$O(^LR(LRDFN,LRI,LRJ)) Q:'LRJ I $O(^LR(LRDFN,LRI,LRJ,5,0)) D Q
. . S LRREF=LRROOT_LRI_",0",LRREC=LRREC+1 D AUCHK^LRRPL S $P(LRREC(LRREC),"^",2)=LRI
. . S LRREC(LRREC,0)=$G(LRSEC(LRDFN,"AY"))
;
; Autospy comments (AZC)
S LRI="AZC"
I $D(^LR(LRDFN,LRI)) D
. S LRREF=LRROOT_LRI,LRREC=LRREC+1 D AUCHK^LRRPL S $P(LRREC(LRREC),"^",2)=LRI
. S LRREC(LRREC,0)=$G(LRSEC(LRDFN,"AZC"))
;
Q
;
;
BUGCHK ; Check for organism/susceptibility
; Only check for susceptibilities on bacteria (3) or TB (12).
;
N LRJ,LRK
S LRJ=0
F S LRJ=$O(^LR(LRDFN,LRSS,LRIDT,LRI,LRJ)) Q:'LRJ D
. S LRREC(LRREC,LRJ)=$P(^LAB(61.2,+^(LRJ,0),0),"^")
. S LRREC(LRREC,LRJ,0)=$G(LRSEC(LRDFN,LRSS,LRIDT,LRI,LRJ))
. I LRI'=3,LRI'=12 Q
. S LRK=2
. F S LRK=$O(^LR(LRDFN,LRSS,LRIDT,LRI,LRJ,LRK)) Q:'LRK!(LRK'<3) D
. . S LRREC(LRREC,LRJ,LRK)=$$GETDRUG^LRRPL(LRI,LRK)
. . S LRREC(LRREC,LRJ,LRK,0)=$G(LRSEC(LRDFN,LRSS,LRIDT,LRI,LRJ,LRK))
Q
;
;
SELMULTI(LRY) ; Handle multiple items type selection
; Flag whole section or indivudual items with performing lab.
; Present list of items and allow all or selected items to be designated
;
; Call with LRY = array of items to select/designate
; Returns LRX = item selected
;
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,I,LRCNT,LRDEC,LRX
;
S (I,LRDEC)=0,LRCNT=$O(LRY(""),-1)
F S I=$O(LRY(I)) Q:'I S DIR("A",I+1)=$J($$LJ^XLFSTR(I,4),13)_" - "_$P(LRY(I),"^") S:I#1=.1 LRDEC=1
S DIR("A")="Select the item to designate (1-"_LRCNT_"): "
S DIR(0)="NAO^1:"_LRCNT_":"_LRDEC,DIR("PRE")="I X'="""",'$D(DTOUT),'$D(LRY(X)) K X"
S DIR("??")="^D EN^DDIOL(.LRPL)"
D ^DIR
I $D(DIRUT) S LRX=-1
E S LRX=Y_"^"_LRY(Y)
;
Q LRX
;
;
GETMULTI ; Build array of existing items in multiple
N LRI
K LRY
S LRI=0
;
I LRSS="MI" D MIMULTI Q
I LRSS?1(1"SP",1"CY",1"EM",1"AU") D APMULTI Q
;
Q
;
;
MIMULTI ; Build array for MI subscript results.
;
N LRX,X
S LRX="^1^^1^^^1^^^1^^^1^1^1^^^1^1^1^1^1^1^1^1^1^1^1^1^1"
I $P(LRX,"^",LRSECT) D Q
. F S LRI=$O(^LR(LRDFN,LRSS,LRIDT,LRSECT,LRI)) Q:'LRI D
. . S X=^LR(LRDFN,LRSS,LRIDT,LRSECT,LRI,0)
. . I LRSECT=14 S X=$P(X,"^")
. . S LRY(LRI)=X_"^"_LRROOT_LRSECT_","_LRI_",0"
. S LRI=$O(LRY(""),-1)+1
. S LRY(LRI)="ALL "_$S(LRSECT=14:"ANTIBIOTIC(for SERUM LEVEL)",1:"comments")_"^"_LRROOT_LRSECT_",0"
;
S LRX="^^1^^^1^^^1^^^1^^^^^1^"
I $P(LRX,"^",LRSECT) D Q
. F S LRI=$O(^LR(LRDFN,LRSS,LRIDT,LRSECT,LRI)) Q:'LRI D
. . S LRY(LRI)=$P(^LAB(61.2,+^(LRI,0),0),"^")_"^"_LRROOT_LRSECT_","_LRI_",0"
. . I LRSECT=3!(LRSECT=12) D
. . . N LRFLAG
. . . S X=$O(^LR(LRDFN,LRSS,LRIDT,LRSECT,LRI,2)),LRFLAG=0
. . . I X\1=2 S LRFLAG=1
. . . I LRSECT=3,$O(^LR(LRDFN,LRSS,LRIDT,LRSECT,LRI,3,0)) S LRFLAG=1
. . . I LRFLAG<1 Q
. . . S LRY(LRI+.1)=$P(LRY(LRI),"^")_" Specific Susceptibilities"_"^"_LRROOT_LRSECT_","_LRI_","
. . . S $P(LRY(LRI),"^")=$P(LRY(LRI),"^")_" including All Susceptibilities"
. S LRI=$O(LRY(""),-1)+1\1,LRY(LRI)="ALL items^"_LRROOT_LRSECT_",0"
;
Q
;
;
MIAB(LRY,LRORG) ; Build array for MI susceptbility results.
; Call with LRY = array to return selections
; LRORG = organism subscript
;
N LRDN,LRI,LRJ
;
S LRI=0,LRJ=2
F S LRJ=$O(^LR(LRDFN,LRSS,LRIDT,LRSECT,LRORG,LRJ)) Q:'LRJ!(LRJ'<3) D
. S LRDN=$$GETDRUG^LRRPL(LRSECT,LRJ)
. S LRI=LRI+1,LRY(LRI)=LRDN_"^"_LRROOT_LRSECT_","_LRORG_","_LRJ
;
; Collect free text antibiotics (#200)
I LRSECT=3,$D(^LR(LRDFN,LRSS,LRIDT,LRSECT,LRORG,3,0)) D
. S LRJ=0
. F S LRJ=$O(^LR(LRDFN,LRSS,LRIDT,LRSECT,LRORG,3,LRJ)) Q:'LRJ D
. . S LRDN=$P(^LR(LRDFN,LRSS,LRIDT,LRSECT,LRORG,3,LRJ,0),"^")
. . S LRI=LRI+1,LRY(LRI)=LRDN_"^"_LRROOT_LRSECT_","_LRORG_",3,"_LRJ_",0"
Q
;
;
APMULTI ; Build array for AP subscript results.
;
; Autopsy comments (AZC)
I LRSS="AU",LRSECT="AZC" D Q
. F S LRI=$O(^LR(LRDFN,LRSECT,LRI)) Q:'LRI S LRY(LRI)=^(LRI,0)_"^"_LRROOT_LRSECT_","_LRI_",0"
. S LRI=$O(LRY(""),-1)+1,LRY(LRI)="ALL comments^"_LRROOT_LRSECT_",0"
;
; Autopsy Supplementary reports (84)
I LRSS="AU",LRSECT=84 D Q
. F S LRI=$O(^LR(LRDFN,LRSECT,LRI)) Q:'LRI S LRX=$$FMTE^XLFDT(+^(LRI,0),"1MZ"),LRY(LRI)=LRX_"^"_LRROOT_LRSECT_","_LRI_",0"
. S LRI=$O(LRY(""),-1)+1,LRY(LRI)="ALL Supplementary Reports^"_LRROOT_LRSECT_",0"
;
; Autopsy Special Studies (AY)
I LRSS="AU",LRSECT="AY" D Q
. F S LRI=$O(^LR(LRDFN,LRSECT,LRI)) Q:'LRI D
. . S LRX=$P(^LAB(61,+^(LRI,0),0),"^"),LRY(LRI)=LRX_"^"_LRROOT_LRSECT_","_LRI_",0"
. . S LRY(LRI+.1)=$P(LRY(LRI),"^")_" Specific Special Studies"_"^"_LRROOT_LRSECT_","_LRI_","
. . S $P(LRY(LRI),"^")=$P(LRY(LRI),"^")_" including All Special Studies"
. S LRI=$O(LRY(""),-1)+1\1,LRY(LRI)="ALL Special Studies Reports^"_LRROOT_LRSECT_",0"
;
; Comment fields #97 and #99
I LRSECT=97!(LRSECT=99) D Q
. F S LRI=$O(^LR(LRDFN,LRSS,LRIDT,LRSECT,LRI)) Q:'LRI S LRY(LRI)=^(LRI,0)_"^"_LRROOT_LRSECT_","_LRI_",0"
. S LRI=$O(LRY(""),-1)+1,LRY(LRI)="ALL comments^"_LRROOT_LRSECT_",0"
;
; Supplementary Reports
I LRSECT=1.2 D Q
. F S LRI=$O(^LR(LRDFN,LRSS,LRIDT,LRSECT,LRI)) Q:'LRI S LRX=$$FMTE^XLFDT(+^(LRI,0),"1MZ"),LRY(LRI)=LRX_"^"_LRROOT_LRSECT_","_LRI_",0"
. S LRI=$O(LRY(""),-1)+1,LRY(LRI)="ALL Supplementary Reports^"_LRROOT_LRSECT_",0"
;
; Special Studies
I LRSECT=2 D Q
. F S LRI=$O(^LR(LRDFN,LRSS,LRIDT,LRSECT,LRI)) Q:'LRI D
. . S LRX=$P(^LAB(61,+^(LRI,0),0),"^"),LRY(LRI)=LRX_"^"_LRROOT_LRSECT_","_LRI_",0"
. . S LRY(LRI+.1)=$P(LRY(LRI),"^")_" Specific Special Studies"_"^"_LRROOT_LRSECT_","_LRI_","
. . S $P(LRY(LRI),"^")=$P(LRY(LRI),"^")_" including All Special Studies"
. S LRI=$O(LRY(""),-1)+1\1,LRY(LRI)="ALL Special Studies Reports^"_LRROOT_LRSECT_",0"
;
Q
;
;
APSS(LRY,LRORGT) ; Build array for AP special studies.
; Call with LRY = array to return selections
; LRORGT = organ/tissue ien
;
N LRI,LRJ,LRS,LRSST,LRSUB
;
S (LRI,LRJ)=0
; Autopsy Special Studies (AY)
I LRSS="AU",LRSECT="AY" D Q
. F S LRJ=$O(^LR(LRDFN,LRSECT,LRORGT,5,LRJ)) Q:'LRJ D
. . S LRS=^LR(LRDFN,LRSECT,LRORGT,5,LRJ,0),LRSST=$$EXTERNAL^DILFD(63.26,.01,"",$P(LRS,"^"),"")
. . S LRI=LRI+1,LRY(LRI)=LRSST_"^"_LRROOT_LRSECT_","_LRORGT_",5,"_LRJ
;
S LRSUB=$S(LRSS="SP":63.819,LRSS="CY":63.919,1:63.219)
F S LRJ=$O(^LR(LRDFN,LRSS,LRIDT,LRSECT,LRORGT,5,LRJ)) Q:'LRJ D
. S LRS=^LR(LRDFN,LRSS,LRIDT,LRSECT,LRORGT,5,LRJ,0),LRSST=$$EXTERNAL^DILFD(LRSUB,.01,"",$P(LRS,"^"),"")
. S LRI=LRI+1,LRY(LRI)=LRSST_"^"_LRROOT_LRSECT_","_LRORGT_",5,"_LRJ
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRRPLU 17863 printed Sep 23, 2025@19:55:48 Page 2
LRRPLU ;DALOI/JMC - Lab Report Performing Lab Utility ;02/22/13 10:11
+1 ;;5.2;LAB SERVICE;**350,427**;Sep 27, 1994;Build 33
+2 ;
+3 QUIT
+4 ;
+5 ;
EDIT(LRDFN,LRSS,LRIDT) ; Add/edit performing lab for a section of a report
+1 ; Call with LRDFN = File #63 IEN
+2 ; LRSS = File #63 subscript
+3 ; LRIDT = File #63 inverse date/time of specimen
+4 ;
+5 ;
+6 NEW DIR,DIROUT,DIRUT,DUOUT,LRHLP,LRLST,LRPL,LRX,LRY,X,Y
+7 ; Autospy does not have an inverse date/time
+8 IF LRSS="AU"
SET LRIDT=0
+9 IF LRSS="MI"
IF '($$GET^XPAR("ALL","LR ASK PERFORMING LAB MICRO",1,"Q"))
DO NOASK^LRRPLUA
QUIT
+10 IF LRSS?1(1"SP",1"CY",1"EM")
IF '($$GET^XPAR("ALL","LR ASK PERFORMING LAB AP",1,"Q"))
DO NOASK^LRRPLUA
QUIT
+11 FOR
Begin DoDot:1
+12 KILL LRPL,LRLST
+13 DO RETLST^LRRPL(.LRPL,LRDFN,LRSS,LRIDT,2)
+14 ;
+15 IF $DATA(LRPL(0))
Begin DoDot:2
+16 MERGE LRLST=LRPL(0)
KILL LRPL(0)
+17 SET LRPL(.5)="Current performing lab assignments:"
SET LRPL(.6)=" "
End DoDot:2
+18 IF '$TEST
SET LRPL(.5)="Current performing lab assignments: None Listed"
+19 DO EN^DDIOL(.LRPL)
+20 ;
+21 KILL DIR,LRHLP
+22 SET DIR(0)="SO^1:Entire report;2:Specific sections of report"
+23 IF $DATA(LRLST)
SET DIR(0)=DIR(0)_";3:Delete performing laboratory"
+24 IF '$TEST
SET DIR("B")=1
+25 SET DIR("A")="Designate performing laboratory for"
+26 IF $GET(DIR("B"))'=""
SET DIR("?")="Enter a code from the list or '^' to exit."
+27 IF '$TEST
SET DIR("?")="Enter a code from the list or <ENTER> to exit."
+28 MERGE LRHLP=LRPL
+29 SET X=$GET(LRPL)
SET LRHLP(X+1)=" "
SET LRHLP(X+2)=DIR("?")
+30 SET DIR("??")="^D EN^DDIOL(.LRHLP)"
+31 DO ^DIR
+32 IF $DATA(DIRUT)
QUIT
+33 IF Y=1
DO SET1(0)
QUIT
+34 IF Y=2
DO SET2
QUIT
+35 IF Y=3
DO DEL
QUIT
End DoDot:1
if $DATA(DIRUT)
QUIT
+36 ;
+37 QUIT
+38 ;
+39 ;
SET1(LRSECT) ; Set performing lab for entire or major section of report.
+1 ; Update if already set otherwise create a new record.
+2 ; Call with LRSECT = section of report
+3 ;
+4 NEW DIR,DIROUT,DIRUT,DUOUT,LRDIE,LRDPL,LRFDA,LRFLAG,LRIEN,LRREF,LRPLAB
+5 SET LRFLAG=0
+6 IF LRSS?1(1"MI",1"SP",1"CY",1"EM")
SET LRFLAG=1
+7 SET LRDPL=$$GET^XPAR("USR","LR VER DEFAULT PERFORMING LAB",1,"Q")
+8 IF LRDPL<1
SET LRDPL=DUZ(2)
+9 SET LRPLAB=$$SELPL^LRVERA(LRDPL,LRFLAG)
+10 IF LRPLAB<1
QUIT
+11 SET LRREF=LRDFN_","_LRSS_","_LRIDT_","_LRSECT
+12 ;
+13 ; Confirm that user wants to add/update record.
+14 WRITE !
+15 SET DIR(0)="YO"
SET DIR("B")="NO"
+16 SET DIR("A")="Sure you want to "_$SELECT($DATA(^LR(LRDFN,"PL","B",LRREF)):"update",1:"add")_" this record"
+17 DO ^DIR
+18 IF Y'=1
QUIT
+19 ;
+20 ; Update existing entry
+21 IF $DATA(^LR(LRDFN,"PL","B",LRREF))
Begin DoDot:1
+22 DO UEE(LRDFN,LRREF,LRPLAB)
+23 WRITE !,"... assignment updated.",!
End DoDot:1
QUIT
+24 ;
+25 ; Create new entry
+26 DO CNE(LRDFN,LRREF,LRPLAB)
+27 WRITE !,"... assignment created.",!
+28 ;
+29 QUIT
+30 ;
+31 ;
SET2 ; Set performing lab for specific section of report
+1 ;
+2 NEW DIR,DIROUT,DIRUT,DUOUT,I,LRCNT,LRI,LRPLIEN,LRQUIT,LRREC,LRREF,LRROOT,LRSEC,LRSECT,LRX,LRY
+3 ; Find the current existing sections of the report
+4 SET LRREF=""
SET (LRI,LRQUIT,LRREC)=0
+5 SET (LRROOT,LRX)=LRDFN_","_LRSS_","_LRIDT_","
+6 FOR
SET LRX=$ORDER(^LR(LRDFN,"PL","B",LRX))
if LRX=""
QUIT
Begin DoDot:1
+7 IF $PIECE(LRROOT,",",1,3)'=$PIECE(LRX,",",1,3)
SET LRQUIT=1
QUIT
+8 SET LRPLIEN=$ORDER(^LR(LRDFN,"PL","B",LRX,0))
+9 SET LRI=$PIECE(LRX,",",4,99)
SET LRY="LRSEC("_LRDFN_",LRSS,"_LRIDT_",LRI)"
+10 SET @LRY=LRX_"^"_LRPLIEN
End DoDot:1
if LRQUIT
QUIT
+11 ;
+12 IF LRSS="MI"
DO MICHK
+13 IF LRSS?1(1"SP",1"CY",1"EM")
DO APCHK
+14 IF LRSS="AU"
DO AUCHK
+15 ;
+16 WRITE !
+17 IF $GET(LRREC)<1
Begin DoDot:1
+18 SET DIR(0)="E"
SET DIR("A",1)="NO sections to designate."
SET DIR("A")="Press any key to continue"
+19 DO ^DIR
End DoDot:1
QUIT
+20 ;
+21 SET LRCNT=$ORDER(LRREC(""),-1)
+22 FOR I=1:1:LRCNT
SET DIR("A",I)=$JUSTIFY(I,11)_" - "_$PIECE(LRREC(I),"^")
+23 SET DIR("A")="Select the section to designate (1-"_LRCNT_"): "
+24 SET DIR(0)="NOA^1:"_LRCNT_":0"
+25 SET DIR("??")="^D EN^DDIOL(.LRPL)"
+26 DO ^DIR
+27 IF $DATA(DIRUT)
QUIT
+28 ;
+29 SET LRSECT=$PIECE(LRREC(Y),"^",2)
+30 ;
+31 IF LRSS="MI"
Begin DoDot:1
+32 SET LRX="1^^^^1^^^1^^^1^^^^^1^^^^^^^^^^^^^^^1^"
+33 IF $PIECE(LRX,"^",LRSECT)!(LRSECT=99)
DO SET1(LRSECT)
QUIT
+34 ;
+35 SET LRX="^1^1^1^^1^1^^1^1^^1^1^1^1^^1^1^1^1^1^1^1^1^1^1^1^1^1^1^"
+36 IF $PIECE(LRX,"^",LRSECT)
Begin DoDot:2
+37 NEW LRY
+38 DO GETMULTI
+39 WRITE !
SET LRX=$$SELMULTI(.LRY)
+40 IF LRX#1=.1
WRITE !
KILL LRY
DO MIAB(.LRY,$PIECE(LRX,",",5))
SET LRX=$$SELMULTI(.LRY)
+41 SET LRREF=$PIECE(LRX,"^",3)
+42 IF LRREF'=""
DO SETREF
End DoDot:2
End DoDot:1
+43 ;
+44 IF LRSS?1(1"SP",1"CY",1"EM")
Begin DoDot:1
+45 IF LRSECT=1.2!(LRSECT=97)!(LRSECT=99)
Begin DoDot:2
+46 NEW LRY
+47 DO GETMULTI
+48 WRITE !
SET LRX=$$SELMULTI(.LRY)
SET LRREF=$PIECE(LRX,"^",3)
+49 IF LRREF'=""
DO SETREF
End DoDot:2
QUIT
+50 IF LRSECT=2
Begin DoDot:2
+51 NEW LRY
+52 DO GETMULTI
+53 WRITE !
SET LRX=$$SELMULTI(.LRY)
+54 IF LRX#1=.1
WRITE !
KILL LRY
DO APSS(.LRY,$PIECE(LRX,",",5))
SET LRX=$$SELMULTI(.LRY)
+55 SET LRREF=$PIECE(LRX,"^",3)
+56 IF LRREF'=""
DO SETREF
End DoDot:2
QUIT
+57 DO SET1(LRSECT)
End DoDot:1
+58 ;
+59 IF LRSS="AU"
Begin DoDot:1
+60 IF LRSECT=84!(LRSECT="AZC")
Begin DoDot:2
+61 NEW LRY
+62 DO GETMULTI
+63 WRITE !
SET LRX=$$SELMULTI(.LRY)
SET LRREF=$PIECE(LRX,"^",3)
+64 IF LRREF'=""
DO SETREF
End DoDot:2
QUIT
+65 IF LRSECT="AY"
Begin DoDot:2
+66 NEW LRY
+67 DO GETMULTI
+68 WRITE !
SET LRX=$$SELMULTI(.LRY)
+69 IF LRX#1=.1
WRITE !
KILL LRY
DO APSS(.LRY,$PIECE(LRX,",",3))
SET LRX=$$SELMULTI(.LRY)
+70 SET LRREF=$PIECE(LRX,"^",3)
+71 IF LRREF'=""
DO SETREF
End DoDot:2
QUIT
+72 DO SET1(LRSECT)
End DoDot:1
+73 ;
+74 QUIT
+75 ;
+76 ;
SETREF ; Set reference to performing lab in file #63
+1 ; Update if already set otherwise create a new record.
+2 ;
+3 ; Confirm that user wants to add/update record.
+4 NEW DIR,DIROUT,DIRUT,DUOUT,LRDIE,LRDPL,LRFDA,LRFLAG,LRIEN,LRPLAB
+5 ;
+6 SET LRFLAG=0
+7 IF LRSS?1(1"MI",1"SP",1"CY",1"EM",1"AU")
SET LRFLAG=1
+8 SET LRDPL=$$GET^XPAR("USR","LR VER DEFAULT PERFORMING LAB",1,"Q")
+9 IF LRDPL<1
SET LRDPL=DUZ(2)
+10 SET LRPLAB=$$SELPL^LRVERA(LRDPL,LRFLAG)
+11 IF LRPLAB<1
QUIT
+12 ;
+13 WRITE !
+14 KILL DIR
+15 SET DIR(0)="YO"
SET DIR("B")="NO"
+16 SET DIR("A")="Sure you want to "_$SELECT($DATA(^LR(LRDFN,"PL","B",LRREF)):"update",1:"add")_" this record"
+17 DO ^DIR
+18 IF Y'=1
QUIT
+19 ;
+20 ; Update existing entry
+21 IF $DATA(^LR(LRDFN,"PL","B",LRREF))
Begin DoDot:1
+22 DO UEE(LRDFN,LRREF,LRPLAB)
+23 WRITE !,"... assignment updated.",!
End DoDot:1
QUIT
+24 ;
+25 ; Create new entry
+26 DO CNE(LRDFN,LRREF,LRPLAB)
+27 WRITE !,"... assignment created.",!
+28 ;
+29 QUIT
+30 ;
+31 ;
DEL ; Delete existing performing laboratory designations.
+1 ;
+2 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,LRCNT,LRFDA,LRIEN,X,Y
+3 SET LRCNT=$ORDER(LRLST(""),-1)
+4 ;
+5 WRITE !
+6 IF LRCNT=1
SET Y=1
+7 IF LRCNT>1
Begin DoDot:1
+8 SET DIR("A")="Select the section to delete (1-"_LRCNT_"): "
+9 FOR I=1:1:LRCNT
SET DIR("A",I)=$JUSTIFY(I,11)_" - "_$PIECE(LRLST(I),"^",3)
+10 SET DIR(0)="NOA^1:"_LRCNT_":0"
+11 DO ^DIR
End DoDot:1
if $DATA(DIRUT)
QUIT
+12 ;
+13 SET LRIEN=$PIECE(LRLST(Y),"^",2)
+14 ;
+15 ; Confirm that user wants to delete record.
+16 KILL DIR
+17 SET DIR(0)="YO"
SET DIR("B")="NO"
+18 SET DIR("A")="Sure you want to delete this performing lab assignment"
+19 DO ^DIR
+20 IF Y'=1
WRITE !,"... deletion cancelled.",!
QUIT
+21 ;
+22 ; Delete existing entry
+23 DO DEE(LRIEN_","_LRDFN_",")
+24 ;
+25 IF '$DATA(^LR(LRDFN,"PL",LRIEN))
WRITE !,"... assignment deleted.",!
+26 IF '$TEST
WRITE "... assignment NOT deleted.",!
+27 ;
+28 QUIT
+29 ;
+30 ;
UEE(LRDFN,LRREF,LRPLAB) ; Update existing entry
+1 ; Call with LRDFN = File #63 IEN
+2 ; LRREF = File #63 subscript reference
+3 ; LRPLAB = Performing lab as IEN in file #4
+4 ;
+5 NEW LRDIE,LRFDA,LRIEN
+6 SET LRIEN=$ORDER(^LR(LRDFN,"PL","B",LRREF,0))
+7 SET LRFDA(1,63.00012,LRIEN_","_LRDFN_",",.02)=LRPLAB
+8 DO FILE^DIE("","LRFDA(1)","LRDIE(1)")
+9 QUIT
+10 ;
+11 ;
CNE(LRDFN,LRREF,LRPLAB) ; Create new entry
+1 ; Call with LRDFN = File #63 IEN
+2 ; LRREF = File #63 subscript reference
+3 ; LRPLAB = Performing lab as IEN in file #4
+4 ;
+5 NEW LRDIE,LRFDA,LRIEN
+6 SET LRFDA(1,63.00012,"+1,"_LRDFN_",",.01)=LRREF
+7 SET LRFDA(1,63.00012,"+1,"_LRDFN_",",.02)=LRPLAB
+8 DO UPDATE^DIE("","LRFDA(1)","LRIEN","LRDIE(1)")
+9 QUIT
+10 ;
+11 ;
DEE(LRIENS) ; Delete existing entry
+1 ; Call with LRRIENS = File #63 performing lab reference IENS
+2 ;
+3 NEW LRDIE,LRFDA
+4 SET LRFDA(1,63.00012,LRIENS,.01)="@"
+5 DO FILE^DIE("","LRFDA(1)","LRDIE(1)")
+6 QUIT
+7 ;
+8 ;
MICHK ; Check MI for sections to link to a performing lab
+1 ;
+2 NEW I,LRI
+3 ;
+4 ; Bacteriology section
+5 SET LRI=1
+6 IF $DATA(^LR(LRDFN,LRSS,LRIDT,LRI))
Begin DoDot:1
+7 DO MICHK1
+8 NEW LRJ
+9 FOR LRJ=5,6
IF $PIECE(^LR(LRDFN,LRSS,LRIDT,LRI),"^",LRJ)'=""
Begin DoDot:2
+10 SET LRREF=LRROOT_LRI_";"_LRJ
SET LRREC=LRREC+1
DO MICHK^LRRPL
SET $PIECE(LRREC(LRREC),"^",2)=LRI_";"_LRJ
+11 SET LRREC(LRREC,0)=$GET(LRSEC(LRDFN,LRSS,LRIDT,LRI_";"_LRJ))
End DoDot:2
End DoDot:1
+12 ;
+13 ; Gram stain/Organism/Susceptibility/Remark section
+14 FOR LRI=2,3,4
IF $ORDER(^LR(LRDFN,LRSS,LRIDT,LRI,0))
Begin DoDot:1
+15 DO MICHK2
+16 IF LRI=3
DO BUGCHK
End DoDot:1
+17 ;
+18 ; Parasite section - check for parasite and stage info
+19 SET LRI=5
+20 IF $DATA(^LR(LRDFN,LRSS,LRIDT,LRI))
DO MICHK1
+21 ;
+22 FOR LRI=6,7
IF $ORDER(^LR(LRDFN,LRSS,LRIDT,LRI,0))
Begin DoDot:1
+23 DO MICHK2
+24 IF LRI=6
DO BUGCHK
End DoDot:1
+25 ;
+26 ; Mycology section
+27 SET LRI=8
+28 IF $DATA(^LR(LRDFN,LRSS,LRIDT,LRI))
DO MICHK1
+29 ;
+30 FOR LRI=9,10,15
IF $ORDER(^LR(LRDFN,LRSS,LRIDT,LRI,0))
Begin DoDot:1
+31 DO MICHK2
+32 IF LRI=9
DO BUGCHK
End DoDot:1
+33 ;
+34 ; Mycobacteria section - also check for AFB stain
+35 SET LRI=11
+36 IF $DATA(^LR(LRDFN,LRSS,LRIDT,LRI))
Begin DoDot:1
+37 DO MICHK1
+38 IF $PIECE(^LR(LRDFN,LRSS,LRIDT,LRI),"^",3)'=""
Begin DoDot:2
+39 SET LRREF=LRROOT_LRI_";3"
SET LRREC=LRREC+1
DO MICHK^LRRPL
SET $PIECE(LRREC(LRREC),"^",2)=LRI_";3"
+40 SET LRREC(LRREC,0)=$GET(LRSEC(LRDFN,LRSS,LRIDT,LRI_";3"))
End DoDot:2
End DoDot:1
+41 ;
+42 ; TB/Organism/Susceptibilityr/Remark section
+43 FOR LRI=12,13,14
IF $ORDER(^LR(LRDFN,LRSS,LRIDT,LRI,0))
Begin DoDot:1
+44 DO MICHK2
+45 IF LRI=12
DO BUGCHK
End DoDot:1
+46 ;
+47 ; Virology section
+48 SET LRI=16
+49 IF $DATA(^LR(LRDFN,LRSS,LRIDT,LRI))
DO MICHK1
+50 ;
+51 FOR LRI=17,18
IF $ORDER(^LR(LRDFN,LRSS,LRIDT,LRI,0))
Begin DoDot:1
+52 DO MICHK2
+53 IF LRI=17
DO BUGCHK
End DoDot:1
+54 ;
+55 ; Various preliminary comment sections
+56 FOR LRI=19:1:30
IF $ORDER(^LR(LRDFN,LRSS,LRIDT,LRI,0))
DO MICHK2
+57 ;
+58 ; Sterility Results
+59 SET LRI=31
+60 IF $DATA(^LR(LRDFN,LRSS,LRIDT,LRI))
DO MICHK1
+61 ;
+62 ; Comment on Specimen
+63 SET LRI=99
+64 IF $DATA(^LR(LRDFN,LRSS,LRIDT,LRI))
DO MICHK1
+65 ;
+66 QUIT
+67 ;
+68 ;
MICHK1 ; Common MI checking logic
+1 ;
+2 SET LRREF=LRROOT_LRI
SET LRREC=LRREC+1
DO MICHK^LRRPL
SET $PIECE(LRREC(LRREC),"^",2)=LRI
+3 SET LRREC(LRREC,0)=$GET(LRSEC(LRDFN,LRSS,LRIDT,LRI))
+4 QUIT
+5 ;
+6 ;
MICHK2 ; Common MI checking logic
+1 ;
+2 SET LRREF=LRROOT_LRI_",0"
SET LRREC=LRREC+1
DO MICHK^LRRPL
SET $PIECE(LRREC(LRREC),"^",2)=LRI
+3 SET LRREC(LRREC,0)=$GET(LRSEC(LRDFN,LRSS,LRIDT,LRI,0))
+4 QUIT
+5 ;
+6 ;
APCHK ; Check AP for sections to link to a performing lab
+1 ;
+2 NEW LRI
+3 ;
+4 FOR LRI=.2,.3,.4,.5,1,1.1,1.3,1.4
Begin DoDot:1
+5 IF LRI=1.3
IF LRSS'="SP"
QUIT
+6 IF '$ORDER(^LR(LRDFN,LRSS,LRIDT,LRI,0))
QUIT
+7 SET LRREF=LRROOT_LRI_",0"
SET LRREC=LRREC+1
DO APCHK^LRRPL
SET $PIECE(LRREC(LRREC),"^",2)=LRI
+8 SET LRREC(LRREC,0)=$GET(LRSEC(LRDFN,LRSS,LRIDT,LRI))
End DoDot:1
+9 ;
+10 ; Supplementary Report section (1.2)
+11 SET LRI=1.2
+12 IF $DATA(^LR(LRDFN,LRSS,LRIDT,LRI))
Begin DoDot:1
+13 SET LRREF=LRROOT_LRI_",0"
SET LRREC=LRREC+1
DO APCHK^LRRPL
SET $PIECE(LRREC(LRREC),"^",2)=LRI
+14 SET LRREC(LRREC,0)=$GET(LRSEC(LRDFN,LRSS,LRIDT,LRI))
End DoDot:1
+15 ;
+16 ; Special studies (2)
+17 SET LRI=2
+18 IF $DATA(^LR(LRDFN,LRSS,LRIDT,LRI))
Begin DoDot:1
+19 NEW LRJ
+20 SET LRJ=0
+21 FOR
SET LRJ=$ORDER(^LR(LRDFN,LRSS,LRIDT,LRI,LRJ))
if 'LRJ
QUIT
IF $ORDER(^LR(LRDFN,LRSS,LRIDT,LRI,LRJ,5,0))
Begin DoDot:2
+22 SET LRREF=LRROOT_LRI_",0"
SET LRREC=LRREC+1
DO APCHK^LRRPL
SET $PIECE(LRREC(LRREC),"^",2)=LRI
+23 SET LRREC(LRREC,0)=$GET(LRSEC(LRDFN,LRSS,LRIDT,LRI))
End DoDot:2
QUIT
End DoDot:1
+24 ;
+25 ; Delayed Report Comment (97) / Comment on Specimen (99)
+26 FOR LRI=97,99
IF $DATA(^LR(LRDFN,LRSS,LRIDT,LRI))
Begin DoDot:1
+27 SET LRREF=LRROOT_LRI
SET LRREC=LRREC+1
DO APCHK^LRRPL
SET $PIECE(LRREC(LRREC),"^",2)=LRI
+28 SET LRREC(LRREC,0)=$GET(LRSEC(LRDFN,LRSS,LRIDT,LRI))
End DoDot:1
+29 ;
+30 QUIT
+31 ;
+32 ;
AUCHK ; Check AU for sections to link to a performing lab
+1 ;
+2 NEW LRI
+3 ;
+4 ; Clinical Diagnoses (81) / Pathological Diagnoses (82)
+5 FOR LRI=81,82
Begin DoDot:1
+6 IF '$ORDER(^LR(LRDFN,LRI,0))
QUIT
+7 SET LRREF=LRROOT_LRI
SET LRREC=LRREC+1
DO AUCHK^LRRPL
SET $PIECE(LRREC(LRREC),"^",2)=LRI
+8 SET LRREC(LRREC,0)=$GET(LRSEC(LRDFN,LRI))
End DoDot:1
+9 ;
+10 ; Supplementary Report section (84)
+11 SET LRI=84
+12 IF $DATA(^LR(LRDFN,LRI))
Begin DoDot:1
+13 SET LRREF=LRROOT_LRI_",0"
SET LRREC=LRREC+1
DO AUCHK^LRRPL
SET $PIECE(LRREC(LRREC),"^",2)=LRI
+14 SET LRREC(LRREC,0)=$GET(LRSEC(LRDFN,LRI))
+15 End DoDot:1
+16 ; Special studies (AY)
+17 SET LRI="AY"
+18 IF $DATA(^LR(LRDFN,LRI))
Begin DoDot:1
+19 NEW LRJ
+20 SET LRJ=0
+21 FOR
SET LRJ=$ORDER(^LR(LRDFN,LRI,LRJ))
if 'LRJ
QUIT
IF $ORDER(^LR(LRDFN,LRI,LRJ,5,0))
Begin DoDot:2
+22 SET LRREF=LRROOT_LRI_",0"
SET LRREC=LRREC+1
DO AUCHK^LRRPL
SET $PIECE(LRREC(LRREC),"^",2)=LRI
+23 SET LRREC(LRREC,0)=$GET(LRSEC(LRDFN,"AY"))
End DoDot:2
QUIT
End DoDot:1
+24 ;
+25 ; Autospy comments (AZC)
+26 SET LRI="AZC"
+27 IF $DATA(^LR(LRDFN,LRI))
Begin DoDot:1
+28 SET LRREF=LRROOT_LRI
SET LRREC=LRREC+1
DO AUCHK^LRRPL
SET $PIECE(LRREC(LRREC),"^",2)=LRI
+29 SET LRREC(LRREC,0)=$GET(LRSEC(LRDFN,"AZC"))
End DoDot:1
+30 ;
+31 QUIT
+32 ;
+33 ;
BUGCHK ; Check for organism/susceptibility
+1 ; Only check for susceptibilities on bacteria (3) or TB (12).
+2 ;
+3 NEW LRJ,LRK
+4 SET LRJ=0
+5 FOR
SET LRJ=$ORDER(^LR(LRDFN,LRSS,LRIDT,LRI,LRJ))
if 'LRJ
QUIT
Begin DoDot:1
+6 SET LRREC(LRREC,LRJ)=$PIECE(^LAB(61.2,+^(LRJ,0),0),"^")
+7 SET LRREC(LRREC,LRJ,0)=$GET(LRSEC(LRDFN,LRSS,LRIDT,LRI,LRJ))
+8 IF LRI'=3
IF LRI'=12
QUIT
+9 SET LRK=2
+10 FOR
SET LRK=$ORDER(^LR(LRDFN,LRSS,LRIDT,LRI,LRJ,LRK))
if 'LRK!(LRK'<3)
QUIT
Begin DoDot:2
+11 SET LRREC(LRREC,LRJ,LRK)=$$GETDRUG^LRRPL(LRI,LRK)
+12 SET LRREC(LRREC,LRJ,LRK,0)=$GET(LRSEC(LRDFN,LRSS,LRIDT,LRI,LRJ,LRK))
End DoDot:2
End DoDot:1
+13 QUIT
+14 ;
+15 ;
SELMULTI(LRY) ; Handle multiple items type selection
+1 ; Flag whole section or indivudual items with performing lab.
+2 ; Present list of items and allow all or selected items to be designated
+3 ;
+4 ; Call with LRY = array of items to select/designate
+5 ; Returns LRX = item selected
+6 ;
+7 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,I,LRCNT,LRDEC,LRX
+8 ;
+9 SET (I,LRDEC)=0
SET LRCNT=$ORDER(LRY(""),-1)
+10 FOR
SET I=$ORDER(LRY(I))
if 'I
QUIT
SET DIR("A",I+1)=$JUSTIFY($$LJ^XLFSTR(I,4),13)_" - "_$PIECE(LRY(I),"^")
if I#1=.1
SET LRDEC=1
+11 SET DIR("A")="Select the item to designate (1-"_LRCNT_"): "
+12 SET DIR(0)="NAO^1:"_LRCNT_":"_LRDEC
SET DIR("PRE")="I X'="""",'$D(DTOUT),'$D(LRY(X)) K X"
+13 SET DIR("??")="^D EN^DDIOL(.LRPL)"
+14 DO ^DIR
+15 IF $DATA(DIRUT)
SET LRX=-1
+16 IF '$TEST
SET LRX=Y_"^"_LRY(Y)
+17 ;
+18 QUIT LRX
+19 ;
+20 ;
GETMULTI ; Build array of existing items in multiple
+1 NEW LRI
+2 KILL LRY
+3 SET LRI=0
+4 ;
+5 IF LRSS="MI"
DO MIMULTI
QUIT
+6 IF LRSS?1(1"SP",1"CY",1"EM",1"AU")
DO APMULTI
QUIT
+7 ;
+8 QUIT
+9 ;
+10 ;
MIMULTI ; Build array for MI subscript results.
+1 ;
+2 NEW LRX,X
+3 SET LRX="^1^^1^^^1^^^1^^^1^1^1^^^1^1^1^1^1^1^1^1^1^1^1^1^1"
+4 IF $PIECE(LRX,"^",LRSECT)
Begin DoDot:1
+5 FOR
SET LRI=$ORDER(^LR(LRDFN,LRSS,LRIDT,LRSECT,LRI))
if 'LRI
QUIT
Begin DoDot:2
+6 SET X=^LR(LRDFN,LRSS,LRIDT,LRSECT,LRI,0)
+7 IF LRSECT=14
SET X=$PIECE(X,"^")
+8 SET LRY(LRI)=X_"^"_LRROOT_LRSECT_","_LRI_",0"
End DoDot:2
+9 SET LRI=$ORDER(LRY(""),-1)+1
+10 SET LRY(LRI)="ALL "_$SELECT(LRSECT=14:"ANTIBIOTIC(for SERUM LEVEL)",1:"comments")_"^"_LRROOT_LRSECT_",0"
End DoDot:1
QUIT
+11 ;
+12 SET LRX="^^1^^^1^^^1^^^1^^^^^1^"
+13 IF $PIECE(LRX,"^",LRSECT)
Begin DoDot:1
+14 FOR
SET LRI=$ORDER(^LR(LRDFN,LRSS,LRIDT,LRSECT,LRI))
if 'LRI
QUIT
Begin DoDot:2
+15 SET LRY(LRI)=$PIECE(^LAB(61.2,+^(LRI,0),0),"^")_"^"_LRROOT_LRSECT_","_LRI_",0"
+16 IF LRSECT=3!(LRSECT=12)
Begin DoDot:3
+17 NEW LRFLAG
+18 SET X=$ORDER(^LR(LRDFN,LRSS,LRIDT,LRSECT,LRI,2))
SET LRFLAG=0
+19 IF X\1=2
SET LRFLAG=1
+20 IF LRSECT=3
IF $ORDER(^LR(LRDFN,LRSS,LRIDT,LRSECT,LRI,3,0))
SET LRFLAG=1
+21 IF LRFLAG<1
QUIT
+22 SET LRY(LRI+.1)=$PIECE(LRY(LRI),"^")_" Specific Susceptibilities"_"^"_LRROOT_LRSECT_","_LRI_","
+23 SET $PIECE(LRY(LRI),"^")=$PIECE(LRY(LRI),"^")_" including All Susceptibilities"
End DoDot:3
End DoDot:2
+24 SET LRI=$ORDER(LRY(""),-1)+1\1
SET LRY(LRI)="ALL items^"_LRROOT_LRSECT_",0"
End DoDot:1
QUIT
+25 ;
+26 QUIT
+27 ;
+28 ;
MIAB(LRY,LRORG) ; Build array for MI susceptbility results.
+1 ; Call with LRY = array to return selections
+2 ; LRORG = organism subscript
+3 ;
+4 NEW LRDN,LRI,LRJ
+5 ;
+6 SET LRI=0
SET LRJ=2
+7 FOR
SET LRJ=$ORDER(^LR(LRDFN,LRSS,LRIDT,LRSECT,LRORG,LRJ))
if 'LRJ!(LRJ'<3)
QUIT
Begin DoDot:1
+8 SET LRDN=$$GETDRUG^LRRPL(LRSECT,LRJ)
+9 SET LRI=LRI+1
SET LRY(LRI)=LRDN_"^"_LRROOT_LRSECT_","_LRORG_","_LRJ
End DoDot:1
+10 ;
+11 ; Collect free text antibiotics (#200)
+12 IF LRSECT=3
IF $DATA(^LR(LRDFN,LRSS,LRIDT,LRSECT,LRORG,3,0))
Begin DoDot:1
+13 SET LRJ=0
+14 FOR
SET LRJ=$ORDER(^LR(LRDFN,LRSS,LRIDT,LRSECT,LRORG,3,LRJ))
if 'LRJ
QUIT
Begin DoDot:2
+15 SET LRDN=$PIECE(^LR(LRDFN,LRSS,LRIDT,LRSECT,LRORG,3,LRJ,0),"^")
+16 SET LRI=LRI+1
SET LRY(LRI)=LRDN_"^"_LRROOT_LRSECT_","_LRORG_",3,"_LRJ_",0"
End DoDot:2
End DoDot:1
+17 QUIT
+18 ;
+19 ;
APMULTI ; Build array for AP subscript results.
+1 ;
+2 ; Autopsy comments (AZC)
+3 IF LRSS="AU"
IF LRSECT="AZC"
Begin DoDot:1
+4 FOR
SET LRI=$ORDER(^LR(LRDFN,LRSECT,LRI))
if 'LRI
QUIT
SET LRY(LRI)=^(LRI,0)_"^"_LRROOT_LRSECT_","_LRI_",0"
+5 SET LRI=$ORDER(LRY(""),-1)+1
SET LRY(LRI)="ALL comments^"_LRROOT_LRSECT_",0"
End DoDot:1
QUIT
+6 ;
+7 ; Autopsy Supplementary reports (84)
+8 IF LRSS="AU"
IF LRSECT=84
Begin DoDot:1
+9 FOR
SET LRI=$ORDER(^LR(LRDFN,LRSECT,LRI))
if 'LRI
QUIT
SET LRX=$$FMTE^XLFDT(+^(LRI,0),"1MZ")
SET LRY(LRI)=LRX_"^"_LRROOT_LRSECT_","_LRI_",0"
+10 SET LRI=$ORDER(LRY(""),-1)+1
SET LRY(LRI)="ALL Supplementary Reports^"_LRROOT_LRSECT_",0"
End DoDot:1
QUIT
+11 ;
+12 ; Autopsy Special Studies (AY)
+13 IF LRSS="AU"
IF LRSECT="AY"
Begin DoDot:1
+14 FOR
SET LRI=$ORDER(^LR(LRDFN,LRSECT,LRI))
if 'LRI
QUIT
Begin DoDot:2
+15 SET LRX=$PIECE(^LAB(61,+^(LRI,0),0),"^")
SET LRY(LRI)=LRX_"^"_LRROOT_LRSECT_","_LRI_",0"
+16 SET LRY(LRI+.1)=$PIECE(LRY(LRI),"^")_" Specific Special Studies"_"^"_LRROOT_LRSECT_","_LRI_","
+17 SET $PIECE(LRY(LRI),"^")=$PIECE(LRY(LRI),"^")_" including All Special Studies"
End DoDot:2
+18 SET LRI=$ORDER(LRY(""),-1)+1\1
SET LRY(LRI)="ALL Special Studies Reports^"_LRROOT_LRSECT_",0"
End DoDot:1
QUIT
+19 ;
+20 ; Comment fields #97 and #99
+21 IF LRSECT=97!(LRSECT=99)
Begin DoDot:1
+22 FOR
SET LRI=$ORDER(^LR(LRDFN,LRSS,LRIDT,LRSECT,LRI))
if 'LRI
QUIT
SET LRY(LRI)=^(LRI,0)_"^"_LRROOT_LRSECT_","_LRI_",0"
+23 SET LRI=$ORDER(LRY(""),-1)+1
SET LRY(LRI)="ALL comments^"_LRROOT_LRSECT_",0"
End DoDot:1
QUIT
+24 ;
+25 ; Supplementary Reports
+26 IF LRSECT=1.2
Begin DoDot:1
+27 FOR
SET LRI=$ORDER(^LR(LRDFN,LRSS,LRIDT,LRSECT,LRI))
if 'LRI
QUIT
SET LRX=$$FMTE^XLFDT(+^(LRI,0),"1MZ")
SET LRY(LRI)=LRX_"^"_LRROOT_LRSECT_","_LRI_",0"
+28 SET LRI=$ORDER(LRY(""),-1)+1
SET LRY(LRI)="ALL Supplementary Reports^"_LRROOT_LRSECT_",0"
End DoDot:1
QUIT
+29 ;
+30 ; Special Studies
+31 IF LRSECT=2
Begin DoDot:1
+32 FOR
SET LRI=$ORDER(^LR(LRDFN,LRSS,LRIDT,LRSECT,LRI))
if 'LRI
QUIT
Begin DoDot:2
+33 SET LRX=$PIECE(^LAB(61,+^(LRI,0),0),"^")
SET LRY(LRI)=LRX_"^"_LRROOT_LRSECT_","_LRI_",0"
+34 SET LRY(LRI+.1)=$PIECE(LRY(LRI),"^")_" Specific Special Studies"_"^"_LRROOT_LRSECT_","_LRI_","
+35 SET $PIECE(LRY(LRI),"^")=$PIECE(LRY(LRI),"^")_" including All Special Studies"
End DoDot:2
+36 SET LRI=$ORDER(LRY(""),-1)+1\1
SET LRY(LRI)="ALL Special Studies Reports^"_LRROOT_LRSECT_",0"
End DoDot:1
QUIT
+37 ;
+38 QUIT
+39 ;
+40 ;
APSS(LRY,LRORGT) ; Build array for AP special studies.
+1 ; Call with LRY = array to return selections
+2 ; LRORGT = organ/tissue ien
+3 ;
+4 NEW LRI,LRJ,LRS,LRSST,LRSUB
+5 ;
+6 SET (LRI,LRJ)=0
+7 ; Autopsy Special Studies (AY)
+8 IF LRSS="AU"
IF LRSECT="AY"
Begin DoDot:1
+9 FOR
SET LRJ=$ORDER(^LR(LRDFN,LRSECT,LRORGT,5,LRJ))
if 'LRJ
QUIT
Begin DoDot:2
+10 SET LRS=^LR(LRDFN,LRSECT,LRORGT,5,LRJ,0)
SET LRSST=$$EXTERNAL^DILFD(63.26,.01,"",$PIECE(LRS,"^"),"")
+11 SET LRI=LRI+1
SET LRY(LRI)=LRSST_"^"_LRROOT_LRSECT_","_LRORGT_",5,"_LRJ
End DoDot:2
End DoDot:1
QUIT
+12 ;
+13 SET LRSUB=$SELECT(LRSS="SP":63.819,LRSS="CY":63.919,1:63.219)
+14 FOR
SET LRJ=$ORDER(^LR(LRDFN,LRSS,LRIDT,LRSECT,LRORGT,5,LRJ))
if 'LRJ
QUIT
Begin DoDot:1
+15 SET LRS=^LR(LRDFN,LRSS,LRIDT,LRSECT,LRORGT,5,LRJ,0)
SET LRSST=$$EXTERNAL^DILFD(LRSUB,.01,"",$PIECE(LRS,"^"),"")
+16 SET LRI=LRI+1
SET LRY(LRI)=LRSST_"^"_LRROOT_LRSECT_","_LRORGT_",5,"_LRJ
End DoDot:1
+17 QUIT
