Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: LRGP1

LRGP1.m

Go to the documentation of this file.
  1. LRGP1 ;DALOI/CJS/RWF - COMMON PARTS TO INSTRUMENT GROUP VERIFY/CHECK ;5/13/03 13:21
  1. ;;5.2;LAB SERVICE;**112,269,286**;Sep 27, 1994
  1. ;
  1. N %DT,%ZIS,DIC,I,J
  1. ;
  1. S LRWT="",LREND=0
  1. S LRTM60=9999999-$$HTFM^XLFDT($H-$P($G(^LAB(69.9,1,0)),U,7),1)
  1. ;
  1. S DIC="^LRO(68.2,",DIC(0)="AEMZQ" D ^DIC
  1. I Y<1 D LREND Q
  1. S LRLL=+Y,LRWT=$P(Y(0),U,8),LRMAXCUP=$P(Y(0),U,4)
  1. ;
  1. S LRPROF=$O(^LRO(68.2,LRLL,10,0))
  1. I LRPROF<1 W !,"No profile defined." D LREND Q
  1. ; If multiple profile then ask which profile
  1. S B=$O(^LRO(68.2,LRLL,10,LRPROF))
  1. I B>0 S DIC="^LRO(68.2,"_LRLL_",10," D ^DIC G LREND:Y<1 S LRPROF=+Y
  1. S LRPANEL=$P(^LRO(68.2,LRLL,10,LRPROF,0),U,1),LRLIST=$O(^LRO(68.2,LRLL,1,LRPROF,1,0))
  1. ;
  1. W !
  1. ;
  1. ; Select performing laboratory to use
  1. I '$D(LRGVP) D
  1. . N X,LRX
  1. . S X=$P(^LRO(68.2,LRLL,10,LRPROF,0),"^",5)
  1. . S LRX=$$SELPL^LRVERA($S(X:X,1:DUZ(2)))
  1. . I LRX<1 D LREND Q
  1. . I LRX,LRX'=DUZ(2) S LRDUZ(2)=LRX
  1. ;
  1. D EXPLODE
  1. I $O(LRVTS(0))<1 D LREND Q
  1. ;
  1. S I=0
  1. 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)
  1. ;
  1. K LRAA
  1. 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)
  1. ;
  1. I '$D(LRAA) D Q:LRAA<1
  1. . S DIC="^LRO(68,",DIC(0)="AEMOQ"
  1. . D ^DIC
  1. . S LRAA=+Y,LRNAME=$P(Y,U,2)
  1. . I LRAA<1 D LREND
  1. I $P(LRPARAM,U,14),$P($G(^LRO(68,LRAA,0)),U,16) D AUTO^LRCAPV
  1. I LREND Q
  1. ;
  1. ; If "VERIFY BY" field empty then ask user
  1. I LRWT="" D Q:LREND
  1. . N DA,DIR,DIRUT,DTOUT,DUOUT,X,Y
  1. . S DIR(0)="68.2,.08"
  1. . D ^DIR
  1. . I $D(DIRUT) D LREND Q
  1. . S LRWT=Y
  1. ;
  1. D ACC:LRWT="A",TRAY:LRWT="T",MACHSQ:LRWT="M",WRKLST:LRWT="W"
  1. Q
  1. ;
  1. ;
  1. LREND ;
  1. S LREND=1
  1. Q
  1. ;
  1. ;
  1. ACC ; Select accession date to verify
  1. ;
  1. N %DT,LRLAN
  1. ;
  1. S LRVBY=1
  1. ; Only ask if verifying, not group printing (LRGP)
  1. I '$D(LRGVP) D
  1. . S LRVBY=$$SELBY^LRWU4("Verify by")
  1. . I LRVBY=0 D LREND
  1. I LREND Q
  1. I LRVBY=2 Q
  1. ;
  1. ; Select accession date
  1. D ADATE^LRWU
  1. I LREND Q
  1. ;
  1. ; Select starting and ending accession numbers
  1. D LRAN^LRWU3
  1. I LREND Q
  1. S LRFAN=LRFAN-1,LRLIX=LRLAN
  1. Q
  1. ;
  1. ;
  1. TRAY ; Select starting and ending tray/cup
  1. ;
  1. N DIR,DIRUT,DTOUT,DUOUT,X,Y
  1. ;
  1. ; Find existing first and last trays on loadlist
  1. S LRFTRAY=$O(^LRO(68.2,LRLL,1,0))
  1. I 'LRFTRAY S LRFTRAY=1
  1. S LRLTRAY=$O(^LRO(68.2,LRLL,1,""),-1)
  1. I 'LRLTRAY S LRLTRAY=LRFTRAY
  1. ;
  1. ; Find existing first and last cups on loadlist
  1. S LRFCUP=$O(^LRO(68.2,LRLL,1,LRFTRAY,1,0))
  1. I 'LRFCUP S LRFCUP=1
  1. S LRLCUP=$O(^LRO(68.2,LRLL,1,LRLTRAY,1,""),-1)
  1. I 'LRLCUP S LRLCUP=LRMAXCUP
  1. ;
  1. S DIR(0)="NO^1:9999999:0",DIR("A")="Starting tray",DIR("B")=1
  1. D ^DIR
  1. I $D(DIRUT) D LREND Q
  1. S LRFTRAY=Y
  1. ;
  1. S DIR(0)="NO^1:9999999:0",DIR("A")="Starting cup",DIR("B")=1
  1. D ^DIR
  1. I $D(DIRUT) D LREND Q
  1. S LRFCUP=Y
  1. ;
  1. S DIR(0)="NO^"_LRFTRAY_":"_LRLTRAY_":0",DIR("A")="Ending tray",DIR("B")=LRLTRAY
  1. D ^DIR
  1. I $D(DIRUT) D LREND Q
  1. S LRLTRAY=Y
  1. ;
  1. S DIR(0)="NO^"_LRFCUP_":"_LRLCUP_":0",DIR("A")="Ending cup",DIR("B")=LRLCUP
  1. D ^DIR
  1. I $D(DIRUT) D LREND Q
  1. S LRLCUP=Y
  1. ;
  1. Q
  1. ;
  1. ;
  1. MACHSQ ; Select starting and ending machine sequence
  1. ;
  1. N DIR,DIRUT,DTOUT,DUOUT,X,Y
  1. ;
  1. S DIR(0)="NO^1:9999999:0",DIR("A")="Starting sequence number",DIR("B")=1
  1. D ^DIR
  1. I $D(DIRUT) D LREND Q
  1. S LRSQ=Y
  1. ;
  1. S DIR(0)="NO^1:9999999:0",DIR("A")="Ending sequence number",DIR("B")=9999999
  1. D ^DIR
  1. I $D(DIRUT) D LREND Q
  1. S LRESEQ=Y
  1. Q
  1. ;
  1. ;
  1. WRKLST ; Select starting and ending worklist numbers
  1. ;
  1. N DIR,DIRUT,DTOUT,DUOUT,X,Y
  1. ;
  1. S DIR(0)="NO^1:9999999:0",DIR("A")="Starting worklist number",DIR("B")=1
  1. D ^DIR
  1. I $D(DIRUT) D LREND Q
  1. S LRCUP=Y
  1. ;
  1. S DIR(0)="NO^1:9999999:0",DIR("A")="Ending worklist number",DIR("B")=9999999
  1. D ^DIR
  1. I $D(DIRUT) D LREND Q
  1. S LRECUP=Y
  1. Q
  1. ;
  1. ;
  1. EXPLODE ;
  1. K LRORD
  1. D EXPLODE^LRGP2
  1. Q