- 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 Feb 18, 2025@23:46:01 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