| 1 | LRGP1 ;DALOI/CJS/RWF - COMMON PARTS TO INSTRUMENT GROUP VERIFY/CHECK ;5/13/03 13:21
|
|---|
| 2 | ;;5.2;LAB SERVICE;**112,269,286**;Sep 27, 1994
|
|---|
| 3 | ;
|
|---|
| 4 | N %DT,%ZIS,DIC,I,J
|
|---|
| 5 | ;
|
|---|
| 6 | S LRWT="",LREND=0
|
|---|
| 7 | S LRTM60=9999999-$$HTFM^XLFDT($H-$P($G(^LAB(69.9,1,0)),U,7),1)
|
|---|
| 8 | ;
|
|---|
| 9 | S DIC="^LRO(68.2,",DIC(0)="AEMZQ" D ^DIC
|
|---|
| 10 | I Y<1 D LREND Q
|
|---|
| 11 | S LRLL=+Y,LRWT=$P(Y(0),U,8),LRMAXCUP=$P(Y(0),U,4)
|
|---|
| 12 | ;
|
|---|
| 13 | S LRPROF=$O(^LRO(68.2,LRLL,10,0))
|
|---|
| 14 | I LRPROF<1 W !,"No profile defined." D LREND Q
|
|---|
| 15 | ; If multiple profile then ask which profile
|
|---|
| 16 | S B=$O(^LRO(68.2,LRLL,10,LRPROF))
|
|---|
| 17 | I B>0 S DIC="^LRO(68.2,"_LRLL_",10," D ^DIC G LREND:Y<1 S LRPROF=+Y
|
|---|
| 18 | S LRPANEL=$P(^LRO(68.2,LRLL,10,LRPROF,0),U,1),LRLIST=$O(^LRO(68.2,LRLL,1,LRPROF,1,0))
|
|---|
| 19 | ;
|
|---|
| 20 | W !
|
|---|
| 21 | ;
|
|---|
| 22 | ; Select performing laboratory to use
|
|---|
| 23 | I '$D(LRGVP) D
|
|---|
| 24 | . N X,LRX
|
|---|
| 25 | . S X=$P(^LRO(68.2,LRLL,10,LRPROF,0),"^",5)
|
|---|
| 26 | . S LRX=$$SELPL^LRVERA($S(X:X,1:DUZ(2)))
|
|---|
| 27 | . I LRX<1 D LREND Q
|
|---|
| 28 | . I LRX,LRX'=DUZ(2) S LRDUZ(2)=LRX
|
|---|
| 29 | ;
|
|---|
| 30 | D EXPLODE
|
|---|
| 31 | I $O(LRVTS(0))<1 D LREND Q
|
|---|
| 32 | ;
|
|---|
| 33 | S I=0
|
|---|
| 34 | F S I=$O(LRORD(I)) Q:I<1 S J=LRORD(I),X=$P(^LAB(60,J,0),U,5),LRORD(I)=$P(X,";",2)
|
|---|
| 35 | ;
|
|---|
| 36 | K LRAA
|
|---|
| 37 | I $L($P(^LRO(68.2,LRLL,10,LRPROF,0),U,2)) S LRAA=$P(^(0),U,2),LRNAME=$P(^LRO(68,LRAA,0),U,1)
|
|---|
| 38 | ;
|
|---|
| 39 | I '$D(LRAA) D Q:LRAA<1
|
|---|
| 40 | . S DIC="^LRO(68,",DIC(0)="AEMOQ"
|
|---|
| 41 | . D ^DIC
|
|---|
| 42 | . S LRAA=+Y,LRNAME=$P(Y,U,2)
|
|---|
| 43 | . I LRAA<1 D LREND
|
|---|
| 44 | I $P(LRPARAM,U,14),$P($G(^LRO(68,LRAA,0)),U,16) D AUTO^LRCAPV
|
|---|
| 45 | I LREND Q
|
|---|
| 46 | ;
|
|---|
| 47 | ; If "VERIFY BY" field empty then ask user
|
|---|
| 48 | I LRWT="" D Q:LREND
|
|---|
| 49 | . N DA,DIR,DIRUT,DTOUT,DUOUT,X,Y
|
|---|
| 50 | . S DIR(0)="68.2,.08"
|
|---|
| 51 | . D ^DIR
|
|---|
| 52 | . I $D(DIRUT) D LREND Q
|
|---|
| 53 | . S LRWT=Y
|
|---|
| 54 | ;
|
|---|
| 55 | D ACC:LRWT="A",TRAY:LRWT="T",MACHSQ:LRWT="M",WRKLST:LRWT="W"
|
|---|
| 56 | Q
|
|---|
| 57 | ;
|
|---|
| 58 | ;
|
|---|
| 59 | LREND ;
|
|---|
| 60 | S LREND=1
|
|---|
| 61 | Q
|
|---|
| 62 | ;
|
|---|
| 63 | ;
|
|---|
| 64 | ACC ; Select accession date to verify
|
|---|
| 65 | ;
|
|---|
| 66 | N %DT,LRLAN
|
|---|
| 67 | ;
|
|---|
| 68 | S LRVBY=1
|
|---|
| 69 | ; Only ask if verifying, not group printing (LRGP)
|
|---|
| 70 | I '$D(LRGVP) D
|
|---|
| 71 | . S LRVBY=$$SELBY^LRWU4("Verify by")
|
|---|
| 72 | . I LRVBY=0 D LREND
|
|---|
| 73 | I LREND Q
|
|---|
| 74 | I LRVBY=2 Q
|
|---|
| 75 | ;
|
|---|
| 76 | ; Select accession date
|
|---|
| 77 | D ADATE^LRWU
|
|---|
| 78 | I LREND Q
|
|---|
| 79 | ;
|
|---|
| 80 | ; Select starting and ending accession numbers
|
|---|
| 81 | D LRAN^LRWU3
|
|---|
| 82 | I LREND Q
|
|---|
| 83 | S LRFAN=LRFAN-1,LRLIX=LRLAN
|
|---|
| 84 | Q
|
|---|
| 85 | ;
|
|---|
| 86 | ;
|
|---|
| 87 | TRAY ; Select starting and ending tray/cup
|
|---|
| 88 | ;
|
|---|
| 89 | N DIR,DIRUT,DTOUT,DUOUT,X,Y
|
|---|
| 90 | ;
|
|---|
| 91 | ; Find existing first and last trays on loadlist
|
|---|
| 92 | S LRFTRAY=$O(^LRO(68.2,LRLL,1,0))
|
|---|
| 93 | I 'LRFTRAY S LRFTRAY=1
|
|---|
| 94 | S LRLTRAY=$O(^LRO(68.2,LRLL,1,""),-1)
|
|---|
| 95 | I 'LRLTRAY S LRLTRAY=LRFTRAY
|
|---|
| 96 | ;
|
|---|
| 97 | ; Find existing first and last cups on loadlist
|
|---|
| 98 | S LRFCUP=$O(^LRO(68.2,LRLL,1,LRFTRAY,1,0))
|
|---|
| 99 | I 'LRFCUP S LRFCUP=1
|
|---|
| 100 | S LRLCUP=$O(^LRO(68.2,LRLL,1,LRLTRAY,1,""),-1)
|
|---|
| 101 | I 'LRLCUP S LRLCUP=LRMAXCUP
|
|---|
| 102 | ;
|
|---|
| 103 | S DIR(0)="NO^1:9999999:0",DIR("A")="Starting tray",DIR("B")=1
|
|---|
| 104 | D ^DIR
|
|---|
| 105 | I $D(DIRUT) D LREND Q
|
|---|
| 106 | S LRFTRAY=Y
|
|---|
| 107 | ;
|
|---|
| 108 | S DIR(0)="NO^1:9999999:0",DIR("A")="Starting cup",DIR("B")=1
|
|---|
| 109 | D ^DIR
|
|---|
| 110 | I $D(DIRUT) D LREND Q
|
|---|
| 111 | S LRFCUP=Y
|
|---|
| 112 | ;
|
|---|
| 113 | S DIR(0)="NO^"_LRFTRAY_":"_LRLTRAY_":0",DIR("A")="Ending tray",DIR("B")=LRLTRAY
|
|---|
| 114 | D ^DIR
|
|---|
| 115 | I $D(DIRUT) D LREND Q
|
|---|
| 116 | S LRLTRAY=Y
|
|---|
| 117 | ;
|
|---|
| 118 | S DIR(0)="NO^"_LRFCUP_":"_LRLCUP_":0",DIR("A")="Ending cup",DIR("B")=LRLCUP
|
|---|
| 119 | D ^DIR
|
|---|
| 120 | I $D(DIRUT) D LREND Q
|
|---|
| 121 | S LRLCUP=Y
|
|---|
| 122 | ;
|
|---|
| 123 | Q
|
|---|
| 124 | ;
|
|---|
| 125 | ;
|
|---|
| 126 | MACHSQ ; Select starting and ending machine sequence
|
|---|
| 127 | ;
|
|---|
| 128 | N DIR,DIRUT,DTOUT,DUOUT,X,Y
|
|---|
| 129 | ;
|
|---|
| 130 | S DIR(0)="NO^1:9999999:0",DIR("A")="Starting sequence number",DIR("B")=1
|
|---|
| 131 | D ^DIR
|
|---|
| 132 | I $D(DIRUT) D LREND Q
|
|---|
| 133 | S LRSQ=Y
|
|---|
| 134 | ;
|
|---|
| 135 | S DIR(0)="NO^1:9999999:0",DIR("A")="Ending sequence number",DIR("B")=9999999
|
|---|
| 136 | D ^DIR
|
|---|
| 137 | I $D(DIRUT) D LREND Q
|
|---|
| 138 | S LRESEQ=Y
|
|---|
| 139 | Q
|
|---|
| 140 | ;
|
|---|
| 141 | ;
|
|---|
| 142 | WRKLST ; Select starting and ending worklist numbers
|
|---|
| 143 | ;
|
|---|
| 144 | N DIR,DIRUT,DTOUT,DUOUT,X,Y
|
|---|
| 145 | ;
|
|---|
| 146 | S DIR(0)="NO^1:9999999:0",DIR("A")="Starting worklist number",DIR("B")=1
|
|---|
| 147 | D ^DIR
|
|---|
| 148 | I $D(DIRUT) D LREND Q
|
|---|
| 149 | S LRCUP=Y
|
|---|
| 150 | ;
|
|---|
| 151 | S DIR(0)="NO^1:9999999:0",DIR("A")="Ending worklist number",DIR("B")=9999999
|
|---|
| 152 | D ^DIR
|
|---|
| 153 | I $D(DIRUT) D LREND Q
|
|---|
| 154 | S LRECUP=Y
|
|---|
| 155 | Q
|
|---|
| 156 | ;
|
|---|
| 157 | ;
|
|---|
| 158 | EXPLODE ;
|
|---|
| 159 | K LRORD
|
|---|
| 160 | D EXPLODE^LRGP2
|
|---|
| 161 | Q
|
|---|
