- GMTSLREM ; SLC/JER,KER - Electron Microscopy Comp Dvr ; 02/27/2002
- ;;2.7;Health Summary;**28,49**;Oct 20, 1995
- ;
- ; External Reference
- ; DBIA 10035 ^DPT(
- ;
- MAIN ; Main Entry Point
- N GMI,MAX,LRDFN,IX,X,IX0 Q:'$D(^DPT(DFN,"LR"))
- S LRDFN=+($G(^DPT(DFN,"LR")))
- S MAX=$S(+($G(GMTSNDM))>0:+($G(GMTSNDM)),1:99999)
- D ^GMTSLREE Q:'$D(^TMP("LREM",$J)) S IX=0
- F GMI=1:1:MAX S IX=$O(^TMP("LREM",$J,IX)) Q:IX'>0 D:GMI>1 CKP^GMTSUP Q:$D(GMTSQIT) W:GMI>1&('GMTSNPG) ! D
- . S IX0=""
- . F S IX0=$O(^TMP("LREM",$J,IX,IX0)) Q:IX0=""!(IX0?1A) D
- . . S X=^TMP("LREM",$J,IX,IX0) D WRT
- . I $D(^TMP("LREM",$J,IX,1.2)) D SUPPR
- K ^TMP("LREM",$J)
- Q
- WRT ; Writes Electron Microscopy Record
- N IX1,GMJ I IX0=0 D Q
- . D CKP^GMTSUP Q:$D(GMTSQIT)
- . W ?8,"Collected:",?19,$P(X,U),?31,"Acc:",?36,$P(X,U,2),!
- I IX0=.1 D WRTSPC Q
- I $S(IX0=.2:1,IX0=1:1,IX0=1.1:1,IX0=1.3:1,IX0=1.4:1,1:0) D TEXT Q
- I IX0=2 S IX1=0 F S IX1=$O(^TMP("LREM",$J,IX,IX0,IX1)) Q:IX1'>0 S X=^(IX1) D WRTP
- Q
- WRTSPC ; Writes Specimen field entries
- N GMS D CKP^GMTSUP Q:$D(GMTSQIT) W ?9,"Specimen:" S GMS=0
- F S GMS=$O(^TMP("LREM",$J,IX,.1,GMS)) Q:GMS'>0 D CKP^GMTSUP Q:$D(GMTSQIT) W ?19,^TMP("LREM",$J,IX,.1,GMS),!
- Q
- TEXT ; Handles GROSS DESCRIPTION & MICROSCOPIC EXAM/DX Print
- N LN,GMTSLN,GMTSLNI D CKP^GMTSUP Q:$D(GMTSQIT) W ?(17-$L(X)),X_":",!
- S LN=0 F S LN=$O(^TMP("LREM",$J,IX,IX0,LN)) Q:LN'>0 S GMTSLN=^(LN) D
- . I $L(GMTSLN)>78 S GMTSLN=$$WRAP^GMTSORC(GMTSLN,78)
- . D CKP^GMTSUP Q:$D(GMTSQIT) W $P(GMTSLN,"|"),! D
- . . F GMTSLNI=2:1:$L(GMTSLN,"|") D CKP^GMTSUP Q:$D(GMTSQIT) W:$P(GMTSLN,"|",GMTSLNI)]"" $P(GMTSLN,"|",GMTSLNI),!
- Q
- SUPPR ; Writes Supplementary Report
- N GMTSR,SRDATE,GMTSRL,GMTSRLI,X S IX1=0
- F S IX1=$O(^TMP("LREM",$J,IX,1.2,IX1)) Q:IX1'>0 D CKP^GMTSUP Q:$D(GMTSQIT) S SRDATE=^TMP("LREM",$J,IX,1.2,IX1,0) S X=SRDATE D REGDTM4^GMTSU W "Supplementary Rpt: ",X,! D
- . S GMTSR=0
- . F S GMTSR=$O(^TMP("LREM",$J,IX,1.2,IX1,GMTSR)) Q:GMTSR'>0 S GMTSRL=^(GMTSR) D
- . . I $L(GMTSRL)>78 S GMTSRL=$$WRAP^GMTSORC(GMTSRL,78)
- . . W $P(GMTSRL,"|"),! D
- . . . F GMTSRLI=2:1:$L(GMTSRL,"|") D CKP^GMTSUP Q:$D(GMTSQIT) W:$P(GMTSRL,"|",GMTSRLI)]"" $P(GMTSRL,"|",GMTSRLI),!
- Q
- WRTP ; Writes Procedure field
- N GMQ,GMK
- I $O(^TMP("LREM",$J,IX,IX0,IX1,4,0)) D Q:$D(GMTSQIT)
- . D CKP^GMTSUP Q:$D(GMTSQIT) W ?7,"Procedures:"
- S GMT=0
- F S GMT=$O(^TMP("LREM",$J,IX,IX0,IX1,4,GMT)) Q:GMT'>0 D
- . S GMQ=$P(^TMP("LREM",$J,IX,IX0,IX1,4,GMT),U)
- . I $L(GMQ)>56 S GMQ=$$WRAP^GMTSORC(GMQ,56)
- . D CKP^GMTSUP Q:$D(GMTSQIT) W ?21,$P(GMQ,"|"),! D
- . . F GMK=2:1:$L(GMQ,"|") D CKP^GMTSUP Q:$D(GMTSQIT) W:$P(GMQ,"|",GMK)]"" ?23,$P(GMQ,"|",GMK),!
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HGMTSLREM 2724 printed Feb 18, 2025@23:24:08 Page 2
- GMTSLREM ; SLC/JER,KER - Electron Microscopy Comp Dvr ; 02/27/2002
- +1 ;;2.7;Health Summary;**28,49**;Oct 20, 1995
- +2 ;
- +3 ; External Reference
- +4 ; DBIA 10035 ^DPT(
- +5 ;
- MAIN ; Main Entry Point
- +1 NEW GMI,MAX,LRDFN,IX,X,IX0
- if '$DATA(^DPT(DFN,"LR"))
- QUIT
- +2 SET LRDFN=+($GET(^DPT(DFN,"LR")))
- +3 SET MAX=$SELECT(+($GET(GMTSNDM))>0:+($GET(GMTSNDM)),1:99999)
- +4 DO ^GMTSLREE
- if '$DATA(^TMP("LREM",$JOB))
- QUIT
- SET IX=0
- +5 FOR GMI=1:1:MAX
- SET IX=$ORDER(^TMP("LREM",$JOB,IX))
- if IX'>0
- QUIT
- if GMI>1
- DO CKP^GMTSUP
- if $DATA(GMTSQIT)
- QUIT
- if GMI>1&('GMTSNPG)
- WRITE !
- Begin DoDot:1
- +6 SET IX0=""
- +7 FOR
- SET IX0=$ORDER(^TMP("LREM",$JOB,IX,IX0))
- if IX0=""!(IX0?1A)
- QUIT
- Begin DoDot:2
- +8 SET X=^TMP("LREM",$JOB,IX,IX0)
- DO WRT
- End DoDot:2
- +9 IF $DATA(^TMP("LREM",$JOB,IX,1.2))
- DO SUPPR
- End DoDot:1
- +10 KILL ^TMP("LREM",$JOB)
- +11 QUIT
- WRT ; Writes Electron Microscopy Record
- +1 NEW IX1,GMJ
- IF IX0=0
- Begin DoDot:1
- +2 DO CKP^GMTSUP
- if $DATA(GMTSQIT)
- QUIT
- +3 WRITE ?8,"Collected:",?19,$PIECE(X,U),?31,"Acc:",?36,$PIECE(X,U,2),!
- End DoDot:1
- QUIT
- +4 IF IX0=.1
- DO WRTSPC
- QUIT
- +5 IF $SELECT(IX0=.2:1,IX0=1:1,IX0=1.1:1,IX0=1.3:1,IX0=1.4:1,1:0)
- DO TEXT
- QUIT
- +6 IF IX0=2
- SET IX1=0
- FOR
- SET IX1=$ORDER(^TMP("LREM",$JOB,IX,IX0,IX1))
- if IX1'>0
- QUIT
- SET X=^(IX1)
- DO WRTP
- +7 QUIT
- WRTSPC ; Writes Specimen field entries
- +1 NEW GMS
- DO CKP^GMTSUP
- if $DATA(GMTSQIT)
- QUIT
- WRITE ?9,"Specimen:"
- SET GMS=0
- +2 FOR
- SET GMS=$ORDER(^TMP("LREM",$JOB,IX,.1,GMS))
- if GMS'>0
- QUIT
- DO CKP^GMTSUP
- if $DATA(GMTSQIT)
- QUIT
- WRITE ?19,^TMP("LREM",$JOB,IX,.1,GMS),!
- +3 QUIT
- TEXT ; Handles GROSS DESCRIPTION & MICROSCOPIC EXAM/DX Print
- +1 NEW LN,GMTSLN,GMTSLNI
- DO CKP^GMTSUP
- if $DATA(GMTSQIT)
- QUIT
- WRITE ?(17-$LENGTH(X)),X_":",!
- +2 SET LN=0
- FOR
- SET LN=$ORDER(^TMP("LREM",$JOB,IX,IX0,LN))
- if LN'>0
- QUIT
- SET GMTSLN=^(LN)
- Begin DoDot:1
- +3 IF $LENGTH(GMTSLN)>78
- SET GMTSLN=$$WRAP^GMTSORC(GMTSLN,78)
- +4 DO CKP^GMTSUP
- if $DATA(GMTSQIT)
- QUIT
- WRITE $PIECE(GMTSLN,"|"),!
- Begin DoDot:2
- +5 FOR GMTSLNI=2:1:$LENGTH(GMTSLN,"|")
- DO CKP^GMTSUP
- if $DATA(GMTSQIT)
- QUIT
- if $PIECE(GMTSLN,"|",GMTSLNI)]""
- WRITE $PIECE(GMTSLN,"|",GMTSLNI),!
- End DoDot:2
- End DoDot:1
- +6 QUIT
- SUPPR ; Writes Supplementary Report
- +1 NEW GMTSR,SRDATE,GMTSRL,GMTSRLI,X
- SET IX1=0
- +2 FOR
- SET IX1=$ORDER(^TMP("LREM",$JOB,IX,1.2,IX1))
- if IX1'>0
- QUIT
- DO CKP^GMTSUP
- if $DATA(GMTSQIT)
- QUIT
- SET SRDATE=^TMP("LREM",$JOB,IX,1.2,IX1,0)
- SET X=SRDATE
- DO REGDTM4^GMTSU
- WRITE "Supplementary Rpt: ",X,!
- Begin DoDot:1
- +3 SET GMTSR=0
- +4 FOR
- SET GMTSR=$ORDER(^TMP("LREM",$JOB,IX,1.2,IX1,GMTSR))
- if GMTSR'>0
- QUIT
- SET GMTSRL=^(GMTSR)
- Begin DoDot:2
- +5 IF $LENGTH(GMTSRL)>78
- SET GMTSRL=$$WRAP^GMTSORC(GMTSRL,78)
- +6 WRITE $PIECE(GMTSRL,"|"),!
- Begin DoDot:3
- +7 FOR GMTSRLI=2:1:$LENGTH(GMTSRL,"|")
- DO CKP^GMTSUP
- if $DATA(GMTSQIT)
- QUIT
- if $PIECE(GMTSRL,"|",GMTSRLI)]""
- WRITE $PIECE(GMTSRL,"|",GMTSRLI),!
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +8 QUIT
- WRTP ; Writes Procedure field
- +1 NEW GMQ,GMK
- +2 IF $ORDER(^TMP("LREM",$JOB,IX,IX0,IX1,4,0))
- Begin DoDot:1
- +3 DO CKP^GMTSUP
- if $DATA(GMTSQIT)
- QUIT
- WRITE ?7,"Procedures:"
- End DoDot:1
- if $DATA(GMTSQIT)
- QUIT
- +4 SET GMT=0
- +5 FOR
- SET GMT=$ORDER(^TMP("LREM",$JOB,IX,IX0,IX1,4,GMT))
- if GMT'>0
- QUIT
- Begin DoDot:1
- +6 SET GMQ=$PIECE(^TMP("LREM",$JOB,IX,IX0,IX1,4,GMT),U)
- +7 IF $LENGTH(GMQ)>56
- SET GMQ=$$WRAP^GMTSORC(GMQ,56)
- +8 DO CKP^GMTSUP
- if $DATA(GMTSQIT)
- QUIT
- WRITE ?21,$PIECE(GMQ,"|"),!
- Begin DoDot:2
- +9 FOR GMK=2:1:$LENGTH(GMQ,"|")
- DO CKP^GMTSUP
- if $DATA(GMTSQIT)
- QUIT
- if $PIECE(GMQ,"|",GMK)]""
- WRITE ?23,$PIECE(GMQ,"|",GMK),!
- End DoDot:2
- End DoDot:1
- +10 QUIT