| [613] | 1 | GMTSLREM ; SLC/JER,KER - Electron Microscopy Comp Dvr ; 02/27/2002
|
|---|
| 2 | ;;2.7;Health Summary;**28,49**;Oct 20, 1995
|
|---|
| 3 | ;
|
|---|
| 4 | ; External Reference
|
|---|
| 5 | ; DBIA 10035 ^DPT(
|
|---|
| 6 | ;
|
|---|
| 7 | MAIN ; Main Entry Point
|
|---|
| 8 | N GMI,MAX,LRDFN,IX,X,IX0 Q:'$D(^DPT(DFN,"LR"))
|
|---|
| 9 | S LRDFN=+($G(^DPT(DFN,"LR")))
|
|---|
| 10 | S MAX=$S(+($G(GMTSNDM))>0:+($G(GMTSNDM)),1:99999)
|
|---|
| 11 | D ^GMTSLREE Q:'$D(^TMP("LREM",$J)) S IX=0
|
|---|
| 12 | 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
|
|---|
| 13 | . S IX0=""
|
|---|
| 14 | . F S IX0=$O(^TMP("LREM",$J,IX,IX0)) Q:IX0=""!(IX0?1A) D
|
|---|
| 15 | . . S X=^TMP("LREM",$J,IX,IX0) D WRT
|
|---|
| 16 | . I $D(^TMP("LREM",$J,IX,1.2)) D SUPPR
|
|---|
| 17 | K ^TMP("LREM",$J)
|
|---|
| 18 | Q
|
|---|
| 19 | WRT ; Writes Electron Microscopy Record
|
|---|
| 20 | N IX1,GMJ I IX0=0 D Q
|
|---|
| 21 | . D CKP^GMTSUP Q:$D(GMTSQIT)
|
|---|
| 22 | . W ?8,"Collected:",?19,$P(X,U),?31,"Acc:",?36,$P(X,U,2),!
|
|---|
| 23 | I IX0=.1 D WRTSPC Q
|
|---|
| 24 | 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
|
|---|
| 25 | I IX0=2 S IX1=0 F S IX1=$O(^TMP("LREM",$J,IX,IX0,IX1)) Q:IX1'>0 S X=^(IX1) D WRTP
|
|---|
| 26 | Q
|
|---|
| 27 | WRTSPC ; Writes Specimen field entries
|
|---|
| 28 | N GMS D CKP^GMTSUP Q:$D(GMTSQIT) W ?9,"Specimen:" S GMS=0
|
|---|
| 29 | 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),!
|
|---|
| 30 | Q
|
|---|
| 31 | TEXT ; Handles GROSS DESCRIPTION & MICROSCOPIC EXAM/DX Print
|
|---|
| 32 | N LN,GMTSLN,GMTSLNI D CKP^GMTSUP Q:$D(GMTSQIT) W ?(17-$L(X)),X_":",!
|
|---|
| 33 | S LN=0 F S LN=$O(^TMP("LREM",$J,IX,IX0,LN)) Q:LN'>0 S GMTSLN=^(LN) D
|
|---|
| 34 | . I $L(GMTSLN)>78 S GMTSLN=$$WRAP^GMTSORC(GMTSLN,78)
|
|---|
| 35 | . D CKP^GMTSUP Q:$D(GMTSQIT) W $P(GMTSLN,"|"),! D
|
|---|
| 36 | . . F GMTSLNI=2:1:$L(GMTSLN,"|") D CKP^GMTSUP Q:$D(GMTSQIT) W:$P(GMTSLN,"|",GMTSLNI)]"" $P(GMTSLN,"|",GMTSLNI),!
|
|---|
| 37 | Q
|
|---|
| 38 | SUPPR ; Writes Supplementary Report
|
|---|
| 39 | N GMTSR,SRDATE,GMTSRL,GMTSRLI,X S IX1=0
|
|---|
| 40 | 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
|
|---|
| 41 | . S GMTSR=0
|
|---|
| 42 | . F S GMTSR=$O(^TMP("LREM",$J,IX,1.2,IX1,GMTSR)) Q:GMTSR'>0 S GMTSRL=^(GMTSR) D
|
|---|
| 43 | . . I $L(GMTSRL)>78 S GMTSRL=$$WRAP^GMTSORC(GMTSRL,78)
|
|---|
| 44 | . . W $P(GMTSRL,"|"),! D
|
|---|
| 45 | . . . F GMTSRLI=2:1:$L(GMTSRL,"|") D CKP^GMTSUP Q:$D(GMTSQIT) W:$P(GMTSRL,"|",GMTSRLI)]"" $P(GMTSRL,"|",GMTSRLI),!
|
|---|
| 46 | Q
|
|---|
| 47 | WRTP ; Writes Procedure field
|
|---|
| 48 | N GMQ,GMK
|
|---|
| 49 | I $O(^TMP("LREM",$J,IX,IX0,IX1,4,0)) D Q:$D(GMTSQIT)
|
|---|
| 50 | . D CKP^GMTSUP Q:$D(GMTSQIT) W ?7,"Procedures:"
|
|---|
| 51 | S GMT=0
|
|---|
| 52 | F S GMT=$O(^TMP("LREM",$J,IX,IX0,IX1,4,GMT)) Q:GMT'>0 D
|
|---|
| 53 | . S GMQ=$P(^TMP("LREM",$J,IX,IX0,IX1,4,GMT),U)
|
|---|
| 54 | . I $L(GMQ)>56 S GMQ=$$WRAP^GMTSORC(GMQ,56)
|
|---|
| 55 | . D CKP^GMTSUP Q:$D(GMTSQIT) W ?21,$P(GMQ,"|"),! D
|
|---|
| 56 | . . F GMK=2:1:$L(GMQ,"|") D CKP^GMTSUP Q:$D(GMTSQIT) W:$P(GMQ,"|",GMK)]"" ?23,$P(GMQ,"|",GMK),!
|
|---|
| 57 | Q
|
|---|
