- LR7OB63C ;DALOI/JMC - Get SP,EM,CY data ;11/10/09 16:31
- ;;5.2;LAB SERVICE;**121,187,315,350**;Sep 27, 1994;Build 230
- ;
- ;
- SS(LRSS) ;Process SP,CY,EM data
- N IFN,IFN1,IFN2,X0,X1,X2,X3,X4,X5,Y1,Y2,Y3,Y4,Y5,Y6,Y7,Y18,CTR1,PATH,SUB,NNN,NN1
- Q:'$G(IVDT)
- S NNN=$S(LRSS="SP":"",LRSS="CY":9,LRSS="EM":2,1:""),NN1=+("63."_$S(LRSS="SP":8,1:NNN)_19)
- Q:'$D(^LR(LRDFN,LRSS,IVDT)) S X0=^(IVDT,0),Y6=$S(+$G(CORRECT):"C",$P(X0,"^",11):"F",$P(X0,"^",3):"R",1:"I"),CTR1=0
- S:+X0 $P(^TMP("LRX",$J,69,CTR,68),"^",4)=+X0 ;DT Specimen Taken
- S:$P(X0,"^",10) $P(^TMP("LRX",$J,69,CTR,68),"^",5)=$P(X0,"^",10) ;DT Received
- S:$P(X0,"^",3) $P(^TMP("LRX",$J,69,CTR,68),"^",6)=$P(X0,"^",3) ;DT Completed
- S PATH=$P(X0,"^",2) ;Pathologist
- S Y18=";"_LRSS_";"_IVDT
- S CTR1=CTR1+1
- S ^TMP("LRX",$J,69,CTR,68,CTR1)=$S($D(^TMP("LRX",$J,69,1)):$P(^TMP("LRX",$J,69,1),"^"),1:"")_"^^"_PATH_"^"_$P(X0,"^",3)
- ;
- D WP(.1,"SPECIMEN","","ST")
- D WP(.2,"BRIEF CLINICAL HISTORY","","TX")
- D WP(.3,"PREOPERATIVE DIAGNOSIS","","TX")
- D WP(.4,"OPERATIVE FINDINGS","","TX")
- D WP(.5,"POSTOPERATIVE DIAGNOSIS","","TX")
- D WP(1,"GROSS DESCRIPTION","&GDT","TX"),MOD(7,"MODIFIED GROSS DESCRIPTION")
- D WP(1.1,"MICROSCOPIC DESCRIPTION","&MDT","TX"),MOD(4,"MODIFIED MICROSCOPIC DESCRIPTION")
- D WP(1.3,"FROZEN SECTION","","TX"),MOD(6,"MODIFIED FROZEN SECTION")
- D WP(1.4,"DIAGNOSIS","","TX"),MOD(5,"MODIFIED DIAGNOSIS")
- ;
- S IFN=0 N X1
- F S IFN=$O(^LR(LRDFN,LRSS,IVDT,1.2,IFN)) Q:IFN<1 S X=^(IFN,0),IFN1=0 D
- . F S IFN1=$O(^LR(LRDFN,LRSS,IVDT,1.2,IFN,1,IFN1)) Q:IFN1<1 D
- . . S CTR1=CTR1+1,X1=^(IFN1,0)
- . . S ^TMP("LRX",$J,69,CTR,63,CTR1)="SUPPLEMENTARY REPORT~"_+X_"^"_X1_"^^^^"_Y6_"^^TX^^^^^^^SUPPLEMNT RPT^^^"_Y18
- ;
- S IFN=0,SUB=0
- F S IFN=$O(^LR(LRDFN,LRSS,IVDT,2,IFN)) Q:IFN<1 S X=^(IFN,0) D
- . S SUB=SUB+1,CTR1=CTR1+1
- . S ^TMP("LRX",$J,69,CTR,63,CTR1)="ORGAN/TISSUE^"_$$POINTER^LR7OB63(+("63."_NNN_12),.01,+X)_"^^^^"_Y6_"^"_SUB_"^CE^"_$P($G(^LAB(61,+X,0)),"^",2)_"^SNM^&ANT^^^^ORG/TISS^^^"_Y18
- . D PTR(1,"DISEASE",+("63."_NNN_15),.01,61.4,"")
- . S IFN1=0
- . F S IFN1=$O(^LR(LRDFN,LRSS,IVDT,2,IFN,2,IFN1)) Q:IFN1<1 S X=^(IFN1,0) D
- .. S CTR1=CTR1+1
- .. S ^TMP("LRX",$J,69,CTR,63,CTR1)="MORPHOLOGY"_"^"_$$POINTER^LR7OB63(+("63."_NNN_16),.01,+X)_"^^^^"_Y6_"^"_SUB_"^CE^"_$P($G(^LAB(61.1,+X,0)),"^",2)_"^SNM^&IMP^^^^_MORPH^^^"_Y18
- .. S IFN2=0
- .. F S IFN2=$O(^LR(LRDFN,LRSS,IVDT,2,IFN,2,IFN1,1,IFN2)) Q:IFN2<1 S X=^(IFN2,0) D
- ... S CTR1=CTR1+1
- ... S ^TMP("LRX",$J,69,CTR,63,CTR1)="ETIOLOGY^"_$$POINTER^LR7OB63(+("63."_NNN_17),.01,+X)_"^^^^"_Y6_"^"_SUB_"^CE^"_$P($G(^LAB(61.2,+X,0)),"^",2)_"^SNM^^^^^ETIOLOGY^^^"_Y18
- . D PTR(3,"FUNCTION",+("63."_NNN_85),.01,61.3,"")
- . D PTR(4,"PROCEDURE",+("63."_NNN_82),.01,61.5,"&CNP")
- . S IFN1=0
- . F S IFN1=$O(^LR(LRDFN,LRSS,IVDT,2,IFN,5,IFN1)) Q:IFN1<1 S X=^(IFN1,0),IFN2=0 F S IFN2=$O(^LR(LRDFN,LRSS,IVDT,2,IFN,5,IFN1,1,IFN2)) Q:IFN2<1 S X1=^(IFN2,0) D
- . . S CTR1=CTR1+1
- . . S ^TMP("LRX",$J,69,CTR,3,CTR1)="SPECIAL STUDIES "_$$SET^LR7OB63(NN1,.01,$P(X,"^"))_"~"_$P(X,"^",2)_"^"_X1_"^^^^^^TX^^^^^^^SPEC STUDIES"_$$SET^LR7OB63(NN1,.01,$P(X,"^"))_"~"_$P(X,"^",2)_"^^^"_Y18
- ;
- S IFN=0 F S IFN=$O(^LR(LRDFN,LRSS,IVDT,3,IFN)) Q:IFN<1 D
- . N LRTMP,LRX
- . S LRX=^(IFN,0),LRX=$$ICDDX^ICDCODE(+LRX,,,1)
- . S CTR1=CTR1+1,LRTMP="ICD DIAGNOSIS^"
- . S LRTMP=LRTMP_$P(LRX,"^",4)_"^^^^"_Y6_"^^CE^"_$P(LRX,"^",2)
- . S LRTMP=LRTMP_"^ICD9^&IMP^^^^^ICD DIAG^^^"_Y18
- . S ^TMP("LRX",$J,69,CTR,63,CTR1)=LRTMP
- ;
- ; Print performing laboratory if designated
- D PPL
- ;
- Q
- ;
- ;
- WP(I,NAME,ID,VALTYP) ;Store word processing fields
- ; I=Node at ^LR(LRDFN,LRSS,IVDT,I)
- ; NAME= Field name
- ; ID=Coded HL7 ID
- ; VALTYP="TX" for text, "CE" for Coded
- N IFN,IFN1,X
- Q:'I Q:'$L(NAME)
- S IFN=0
- F S IFN=$O(^LR(LRDFN,LRSS,IVDT,I,IFN)) Q:IFN<1 S X=^(IFN,0) D SPLIT^LR7OU1(X,"^TMP(""LRX"",$J,69,"_CTR_",63)",.CTR1,80,NAME_"^","^^^^"_Y6_"^^"_VALTYP_"^^^"_ID_"^^^^"_NAME_"^^^"_Y18)
- Q
- ;
- ;
- PTR(I,NAME,FILE,FIELD,SNMFILE,ID) ;Store ptr fields for ORGAN/TISSUE multiple
- ; I=Node at ^LR(LRDFN,LRSS,ICDT,2,IFN,I)
- ; NAME=Field name
- ; FILE=File #
- ; FIELD=Field #
- ; SNMFILE=Snomed file # for coded entry
- ; ID=Procedure ID Natl
- N IFN1
- Q:'I Q:'$L(NAME)
- S IFN1=0
- F S IFN1=$O(^LR(LRDFN,LRSS,IVDT,2,IFN,I,IFN1)) Q:IFN1<1 S X=^(IFN1,0) D
- . S CTR1=CTR1+1
- . S ^TMP("LRX",$J,69,CTR,63,CTR1)=NAME_"^"_$$POINTER^LR7OB63(FILE,FIELD,+X)_"^^^^"_Y6_"^"_SUB_"^CE^"_$P($G(@("^LAB("_SNMFILE_","_+X_",0)")),"^",2)_"^SNM^"_ID_"^^^^"_NAME_"^^^"_Y18
- Q
- ;
- ;
- MOD(IFN,FLDNM) ;Process Modified text fields
- ; IFN=Internal # of modified node
- ; FLDNM=Field name
- Q:'$D(^LR(LRDFN,LRSS,IVDT,+IFN))
- N X,X1
- S IFN1=0
- F S IFN1=$O(^LR(LRDFN,LRSS,IVDT,+IFN,IFN1)) Q:IFN1<1 S X=^(IFN1,0),IFN2=0 D
- . F S IFN2=$O(^LR(LRDFN,LRSS,IVDT,+IFN,IFN1,1,IFN2)) Q:IFN2<1 S X1=^(IFN2,0) D
- . . S CTR1=CTR1+1
- . . S ^TMP("LRX",$J,69,CTR,63,CTR1)=FLDNM_"~"_+X_"^"_X1_"^^^^"_Y6_"^^TX^^^^^^^"_FLDNM_"^^^"_Y18
- Q
- ;
- ;
- PPL ; Print any performing laboratories
- ;
- N LRPL,LRJ
- ;
- D RETLST^LRRPL(.LRPL,LRDFN,LRSS,IVDT,0)
- I $G(LRPL)<1 Q
- ;
- S CTR1=CTR1+1,^TMP("LRX",$J,69,CTR,63,CTR1)=$$REPEAT^XLFSTR("=",IOM)
- S CTR1=CTR1+1,^TMP("LRX",$J,69,CTR,63,CTR1)="Performing Laboratory:"
- S LRJ=0
- F S LRJ=$O(LRPL(LRJ)) Q:'LRJ S CTR1=CTR1+1,^TMP("LRX",$J,69,CTR,63,CTR1)=LRPL(LRJ)
- ;
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLR7OB63C 5354 printed Jan 18, 2025@03:05:34 Page 2
- LR7OB63C ;DALOI/JMC - Get SP,EM,CY data ;11/10/09 16:31
- +1 ;;5.2;LAB SERVICE;**121,187,315,350**;Sep 27, 1994;Build 230
- +2 ;
- +3 ;
- SS(LRSS) ;Process SP,CY,EM data
- +1 NEW IFN,IFN1,IFN2,X0,X1,X2,X3,X4,X5,Y1,Y2,Y3,Y4,Y5,Y6,Y7,Y18,CTR1,PATH,SUB,NNN,NN1
- +2 if '$GET(IVDT)
- QUIT
- +3 SET NNN=$SELECT(LRSS="SP":"",LRSS="CY":9,LRSS="EM":2,1:"")
- SET NN1=+("63."_$SELECT(LRSS="SP":8,1:NNN)_19)
- +4 if '$DATA(^LR(LRDFN,LRSS,IVDT))
- QUIT
- SET X0=^(IVDT,0)
- SET Y6=$SELECT(+$GET(CORRECT):"C",$PIECE(X0,"^",11):"F",$PIECE(X0,"^",3):"R",1:"I")
- SET CTR1=0
- +5 ;DT Specimen Taken
- if +X0
- SET $PIECE(^TMP("LRX",$JOB,69,CTR,68),"^",4)=+X0
- +6 ;DT Received
- if $PIECE(X0,"^",10)
- SET $PIECE(^TMP("LRX",$JOB,69,CTR,68),"^",5)=$PIECE(X0,"^",10)
- +7 ;DT Completed
- if $PIECE(X0,"^",3)
- SET $PIECE(^TMP("LRX",$JOB,69,CTR,68),"^",6)=$PIECE(X0,"^",3)
- +8 ;Pathologist
- SET PATH=$PIECE(X0,"^",2)
- +9 SET Y18=";"_LRSS_";"_IVDT
- +10 SET CTR1=CTR1+1
- +11 SET ^TMP("LRX",$JOB,69,CTR,68,CTR1)=$SELECT($DATA(^TMP("LRX",$JOB,69,1)):$PIECE(^TMP("LRX",$JOB,69,1),"^"),1:"")_"^^"_PATH_"^"_$PIECE(X0,"^",3)
- +12 ;
- +13 DO WP(.1,"SPECIMEN","","ST")
- +14 DO WP(.2,"BRIEF CLINICAL HISTORY","","TX")
- +15 DO WP(.3,"PREOPERATIVE DIAGNOSIS","","TX")
- +16 DO WP(.4,"OPERATIVE FINDINGS","","TX")
- +17 DO WP(.5,"POSTOPERATIVE DIAGNOSIS","","TX")
- +18 DO WP(1,"GROSS DESCRIPTION","&GDT","TX")
- DO MOD(7,"MODIFIED GROSS DESCRIPTION")
- +19 DO WP(1.1,"MICROSCOPIC DESCRIPTION","&MDT","TX")
- DO MOD(4,"MODIFIED MICROSCOPIC DESCRIPTION")
- +20 DO WP(1.3,"FROZEN SECTION","","TX")
- DO MOD(6,"MODIFIED FROZEN SECTION")
- +21 DO WP(1.4,"DIAGNOSIS","","TX")
- DO MOD(5,"MODIFIED DIAGNOSIS")
- +22 ;
- +23 SET IFN=0
- NEW X1
- +24 FOR
- SET IFN=$ORDER(^LR(LRDFN,LRSS,IVDT,1.2,IFN))
- if IFN<1
- QUIT
- SET X=^(IFN,0)
- SET IFN1=0
- Begin DoDot:1
- +25 FOR
- SET IFN1=$ORDER(^LR(LRDFN,LRSS,IVDT,1.2,IFN,1,IFN1))
- if IFN1<1
- QUIT
- Begin DoDot:2
- +26 SET CTR1=CTR1+1
- SET X1=^(IFN1,0)
- +27 SET ^TMP("LRX",$JOB,69,CTR,63,CTR1)="SUPPLEMENTARY REPORT~"_+X_"^"_X1_"^^^^"_Y6_"^^TX^^^^^^^SUPPLEMNT RPT^^^"_Y18
- End DoDot:2
- End DoDot:1
- +28 ;
- +29 SET IFN=0
- SET SUB=0
- +30 FOR
- SET IFN=$ORDER(^LR(LRDFN,LRSS,IVDT,2,IFN))
- if IFN<1
- QUIT
- SET X=^(IFN,0)
- Begin DoDot:1
- +31 SET SUB=SUB+1
- SET CTR1=CTR1+1
- +32 SET ^TMP("LRX",$JOB,69,CTR,63,CTR1)="ORGAN/TISSUE^"_$$POINTER^LR7OB63(+("63."_NNN_12),.01,+X)_"^^^^"_Y6_"^"_SUB_"^CE^"_$PIECE($GET(^LAB(61,+X,0)),"^",2)_"^SNM^&ANT^^^^ORG/TISS^^^"_Y18
- +33 DO PTR(1,"DISEASE",+("63."_NNN_15),.01,61.4,"")
- +34 SET IFN1=0
- +35 FOR
- SET IFN1=$ORDER(^LR(LRDFN,LRSS,IVDT,2,IFN,2,IFN1))
- if IFN1<1
- QUIT
- SET X=^(IFN1,0)
- Begin DoDot:2
- +36 SET CTR1=CTR1+1
- +37 SET ^TMP("LRX",$JOB,69,CTR,63,CTR1)="MORPHOLOGY"_"^"_$$POINTER^LR7OB63(+("63."_NNN_16),.01,+X)_"^^^^"_Y6_"^"_SUB_"^CE^"_$PIECE($GET(^LAB(61.1,+X,0)),"^",2)_"^SNM^&IMP^^^^_MORPH^^^"_Y18
- +38 SET IFN2=0
- +39 FOR
- SET IFN2=$ORDER(^LR(LRDFN,LRSS,IVDT,2,IFN,2,IFN1,1,IFN2))
- if IFN2<1
- QUIT
- SET X=^(IFN2,0)
- Begin DoDot:3
- +40 SET CTR1=CTR1+1
- +41 SET ^TMP("LRX",$JOB,69,CTR,63,CTR1)="ETIOLOGY^"_$$POINTER^LR7OB63(+("63."_NNN_17),.01,+X)_"^^^^"_Y6_"^"_SUB_"^CE^"_$PIECE($GET(^LAB(61.2,+X,0)),"^",2)_"^SNM^^^^^ETIOLOGY^^^"_Y18
- End DoDot:3
- End DoDot:2
- +42 DO PTR(3,"FUNCTION",+("63."_NNN_85),.01,61.3,"")
- +43 DO PTR(4,"PROCEDURE",+("63."_NNN_82),.01,61.5,"&CNP")
- +44 SET IFN1=0
- +45 FOR
- SET IFN1=$ORDER(^LR(LRDFN,LRSS,IVDT,2,IFN,5,IFN1))
- if IFN1<1
- QUIT
- SET X=^(IFN1,0)
- SET IFN2=0
- FOR
- SET IFN2=$ORDER(^LR(LRDFN,LRSS,IVDT,2,IFN,5,IFN1,1,IFN2))
- if IFN2<1
- QUIT
- SET X1=^(IFN2,0)
- Begin DoDot:2
- +46 SET CTR1=CTR1+1
- +47 SET ^TMP("LRX",$JOB,69,CTR,3,CTR1)="SPECIAL STUDIES "_$$SET^LR7OB63(NN1,.01,$PIECE(X,"^"))_"~"_$PIECE(X,"^",2)_"^"_X1_"^^^^^^TX^^^^^^^SPEC STUDIES"_$$SET^LR7OB63(NN1,.01,$PIECE(X,"^"))_"~"_$PIECE(X,"^",2)_"^^^"_Y18
- End DoDot:2
- End DoDot:1
- +48 ;
- +49 SET IFN=0
- FOR
- SET IFN=$ORDER(^LR(LRDFN,LRSS,IVDT,3,IFN))
- if IFN<1
- QUIT
- Begin DoDot:1
- +50 NEW LRTMP,LRX
- +51 SET LRX=^(IFN,0)
- SET LRX=$$ICDDX^ICDCODE(+LRX,,,1)
- +52 SET CTR1=CTR1+1
- SET LRTMP="ICD DIAGNOSIS^"
- +53 SET LRTMP=LRTMP_$PIECE(LRX,"^",4)_"^^^^"_Y6_"^^CE^"_$PIECE(LRX,"^",2)
- +54 SET LRTMP=LRTMP_"^ICD9^&IMP^^^^^ICD DIAG^^^"_Y18
- +55 SET ^TMP("LRX",$JOB,69,CTR,63,CTR1)=LRTMP
- End DoDot:1
- +56 ;
- +57 ; Print performing laboratory if designated
- +58 DO PPL
- +59 ;
- +60 QUIT
- +61 ;
- +62 ;
- WP(I,NAME,ID,VALTYP) ;Store word processing fields
- +1 ; I=Node at ^LR(LRDFN,LRSS,IVDT,I)
- +2 ; NAME= Field name
- +3 ; ID=Coded HL7 ID
- +4 ; VALTYP="TX" for text, "CE" for Coded
- +5 NEW IFN,IFN1,X
- +6 if 'I
- QUIT
- if '$LENGTH(NAME)
- QUIT
- +7 SET IFN=0
- +8 FOR
- SET IFN=$ORDER(^LR(LRDFN,LRSS,IVDT,I,IFN))
- if IFN<1
- QUIT
- SET X=^(IFN,0)
- DO SPLIT^LR7OU1(X,"^TMP(""LRX"",$J,69,"_CTR_",63)",.CTR1,80,NAME_"^","^^^^"_Y6_"^^"_VALTYP_"^^^"_ID_"^^^^"_NAME_"^^^"_Y18)
- +9 QUIT
- +10 ;
- +11 ;
- PTR(I,NAME,FILE,FIELD,SNMFILE,ID) ;Store ptr fields for ORGAN/TISSUE multiple
- +1 ; I=Node at ^LR(LRDFN,LRSS,ICDT,2,IFN,I)
- +2 ; NAME=Field name
- +3 ; FILE=File #
- +4 ; FIELD=Field #
- +5 ; SNMFILE=Snomed file # for coded entry
- +6 ; ID=Procedure ID Natl
- +7 NEW IFN1
- +8 if 'I
- QUIT
- if '$LENGTH(NAME)
- QUIT
- +9 SET IFN1=0
- +10 FOR
- SET IFN1=$ORDER(^LR(LRDFN,LRSS,IVDT,2,IFN,I,IFN1))
- if IFN1<1
- QUIT
- SET X=^(IFN1,0)
- Begin DoDot:1
- +11 SET CTR1=CTR1+1
- +12 SET ^TMP("LRX",$JOB,69,CTR,63,CTR1)=NAME_"^"_$$POINTER^LR7OB63(FILE,FIELD,+X)_"^^^^"_Y6_"^"_SUB_"^CE^"_$PIECE($GET(@("^LAB("_SNMFILE_","_+X_",0)")),"^",2)_"^SNM^"_ID_"^^^^"_NAME_"^^^"_Y18
- End DoDot:1
- +13 QUIT
- +14 ;
- +15 ;
- MOD(IFN,FLDNM) ;Process Modified text fields
- +1 ; IFN=Internal # of modified node
- +2 ; FLDNM=Field name
- +3 if '$DATA(^LR(LRDFN,LRSS,IVDT,+IFN))
- QUIT
- +4 NEW X,X1
- +5 SET IFN1=0
- +6 FOR
- SET IFN1=$ORDER(^LR(LRDFN,LRSS,IVDT,+IFN,IFN1))
- if IFN1<1
- QUIT
- SET X=^(IFN1,0)
- SET IFN2=0
- Begin DoDot:1
- +7 FOR
- SET IFN2=$ORDER(^LR(LRDFN,LRSS,IVDT,+IFN,IFN1,1,IFN2))
- if IFN2<1
- QUIT
- SET X1=^(IFN2,0)
- Begin DoDot:2
- +8 SET CTR1=CTR1+1
- +9 SET ^TMP("LRX",$JOB,69,CTR,63,CTR1)=FLDNM_"~"_+X_"^"_X1_"^^^^"_Y6_"^^TX^^^^^^^"_FLDNM_"^^^"_Y18
- End DoDot:2
- End DoDot:1
- +10 QUIT
- +11 ;
- +12 ;
- PPL ; Print any performing laboratories
- +1 ;
- +2 NEW LRPL,LRJ
- +3 ;
- +4 DO RETLST^LRRPL(.LRPL,LRDFN,LRSS,IVDT,0)
- +5 IF $GET(LRPL)<1
- QUIT
- +6 ;
- +7 SET CTR1=CTR1+1
- SET ^TMP("LRX",$JOB,69,CTR,63,CTR1)=$$REPEAT^XLFSTR("=",IOM)
- +8 SET CTR1=CTR1+1
- SET ^TMP("LRX",$JOB,69,CTR,63,CTR1)="Performing Laboratory:"
- +9 SET LRJ=0
- +10 FOR
- SET LRJ=$ORDER(LRPL(LRJ))
- if 'LRJ
- QUIT
- SET CTR1=CTR1+1
- SET ^TMP("LRX",$JOB,69,CTR,63,CTR1)=LRPL(LRJ)
- +11 ;
- +12 QUIT