- LRGP1 ;DALOI/CJS/RWF - COMMON PARTS TO INSTRUMENT GROUP VERIFY/CHECK ;5/13/03 13:21
- ;;5.2;LAB SERVICE;**112,269,286**;Sep 27, 1994
- ;
- N %DT,%ZIS,DIC,I,J
- ;
- S LRWT="",LREND=0
- S LRTM60=9999999-$$HTFM^XLFDT($H-$P($G(^LAB(69.9,1,0)),U,7),1)
- ;
- S DIC="^LRO(68.2,",DIC(0)="AEMZQ" D ^DIC
- I Y<1 D LREND Q
- S LRLL=+Y,LRWT=$P(Y(0),U,8),LRMAXCUP=$P(Y(0),U,4)
- ;
- S LRPROF=$O(^LRO(68.2,LRLL,10,0))
- I LRPROF<1 W !,"No profile defined." D LREND Q
- ; If multiple profile then ask which profile
- S B=$O(^LRO(68.2,LRLL,10,LRPROF))
- I B>0 S DIC="^LRO(68.2,"_LRLL_",10," D ^DIC G LREND:Y<1 S LRPROF=+Y
- S LRPANEL=$P(^LRO(68.2,LRLL,10,LRPROF,0),U,1),LRLIST=$O(^LRO(68.2,LRLL,1,LRPROF,1,0))
- ;
- W !
- ;
- ; Select performing laboratory to use
- I '$D(LRGVP) D
- . N X,LRX
- . S X=$P(^LRO(68.2,LRLL,10,LRPROF,0),"^",5)
- . S LRX=$$SELPL^LRVERA($S(X:X,1:DUZ(2)))
- . I LRX<1 D LREND Q
- . I LRX,LRX'=DUZ(2) S LRDUZ(2)=LRX
- ;
- D EXPLODE
- I $O(LRVTS(0))<1 D LREND Q
- ;
- S I=0
- 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)
- ;
- K LRAA
- 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)
- ;
- I '$D(LRAA) D Q:LRAA<1
- . S DIC="^LRO(68,",DIC(0)="AEMOQ"
- . D ^DIC
- . S LRAA=+Y,LRNAME=$P(Y,U,2)
- . I LRAA<1 D LREND
- I $P(LRPARAM,U,14),$P($G(^LRO(68,LRAA,0)),U,16) D AUTO^LRCAPV
- I LREND Q
- ;
- ; If "VERIFY BY" field empty then ask user
- I LRWT="" D Q:LREND
- . N DA,DIR,DIRUT,DTOUT,DUOUT,X,Y
- . S DIR(0)="68.2,.08"
- . D ^DIR
- . I $D(DIRUT) D LREND Q
- . S LRWT=Y
- ;
- D ACC:LRWT="A",TRAY:LRWT="T",MACHSQ:LRWT="M",WRKLST:LRWT="W"
- Q
- ;
- ;
- LREND ;
- S LREND=1
- Q
- ;
- ;
- ACC ; Select accession date to verify
- ;
- N %DT,LRLAN
- ;
- S LRVBY=1
- ; Only ask if verifying, not group printing (LRGP)
- I '$D(LRGVP) D
- . S LRVBY=$$SELBY^LRWU4("Verify by")
- . I LRVBY=0 D LREND
- I LREND Q
- I LRVBY=2 Q
- ;
- ; Select accession date
- D ADATE^LRWU
- I LREND Q
- ;
- ; Select starting and ending accession numbers
- D LRAN^LRWU3
- I LREND Q
- S LRFAN=LRFAN-1,LRLIX=LRLAN
- Q
- ;
- ;
- TRAY ; Select starting and ending tray/cup
- ;
- N DIR,DIRUT,DTOUT,DUOUT,X,Y
- ;
- ; Find existing first and last trays on loadlist
- S LRFTRAY=$O(^LRO(68.2,LRLL,1,0))
- I 'LRFTRAY S LRFTRAY=1
- S LRLTRAY=$O(^LRO(68.2,LRLL,1,""),-1)
- I 'LRLTRAY S LRLTRAY=LRFTRAY
- ;
- ; Find existing first and last cups on loadlist
- S LRFCUP=$O(^LRO(68.2,LRLL,1,LRFTRAY,1,0))
- I 'LRFCUP S LRFCUP=1
- S LRLCUP=$O(^LRO(68.2,LRLL,1,LRLTRAY,1,""),-1)
- I 'LRLCUP S LRLCUP=LRMAXCUP
- ;
- S DIR(0)="NO^1:9999999:0",DIR("A")="Starting tray",DIR("B")=1
- D ^DIR
- I $D(DIRUT) D LREND Q
- S LRFTRAY=Y
- ;
- S DIR(0)="NO^1:9999999:0",DIR("A")="Starting cup",DIR("B")=1
- D ^DIR
- I $D(DIRUT) D LREND Q
- S LRFCUP=Y
- ;
- S DIR(0)="NO^"_LRFTRAY_":"_LRLTRAY_":0",DIR("A")="Ending tray",DIR("B")=LRLTRAY
- D ^DIR
- I $D(DIRUT) D LREND Q
- S LRLTRAY=Y
- ;
- S DIR(0)="NO^"_LRFCUP_":"_LRLCUP_":0",DIR("A")="Ending cup",DIR("B")=LRLCUP
- D ^DIR
- I $D(DIRUT) D LREND Q
- S LRLCUP=Y
- ;
- Q
- ;
- ;
- MACHSQ ; Select starting and ending machine sequence
- ;
- N DIR,DIRUT,DTOUT,DUOUT,X,Y
- ;
- S DIR(0)="NO^1:9999999:0",DIR("A")="Starting sequence number",DIR("B")=1
- D ^DIR
- I $D(DIRUT) D LREND Q
- S LRSQ=Y
- ;
- S DIR(0)="NO^1:9999999:0",DIR("A")="Ending sequence number",DIR("B")=9999999
- D ^DIR
- I $D(DIRUT) D LREND Q
- S LRESEQ=Y
- Q
- ;
- ;
- WRKLST ; Select starting and ending worklist numbers
- ;
- N DIR,DIRUT,DTOUT,DUOUT,X,Y
- ;
- S DIR(0)="NO^1:9999999:0",DIR("A")="Starting worklist number",DIR("B")=1
- D ^DIR
- I $D(DIRUT) D LREND Q
- S LRCUP=Y
- ;
- S DIR(0)="NO^1:9999999:0",DIR("A")="Ending worklist number",DIR("B")=9999999
- D ^DIR
- I $D(DIRUT) D LREND Q
- S LRECUP=Y
- Q
- ;
- ;
- EXPLODE ;
- K LRORD
- D EXPLODE^LRGP2
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRGP1 3804 printed Jan 18, 2025@03:15:38 Page 2
- 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
- +2 ;
- +3 NEW %DT,%ZIS,DIC,I,J
- +4 ;
- +5 SET LRWT=""
- SET LREND=0
- +6 SET LRTM60=9999999-$$HTFM^XLFDT($HOROLOG-$PIECE($GET(^LAB(69.9,1,0)),U,7),1)
- +7 ;
- +8 SET DIC="^LRO(68.2,"
- SET DIC(0)="AEMZQ"
- DO ^DIC
- +9 IF Y<1
- DO LREND
- QUIT
- +10 SET LRLL=+Y
- SET LRWT=$PIECE(Y(0),U,8)
- SET LRMAXCUP=$PIECE(Y(0),U,4)
- +11 ;
- +12 SET LRPROF=$ORDER(^LRO(68.2,LRLL,10,0))
- +13 IF LRPROF<1
- WRITE !,"No profile defined."
- DO LREND
- QUIT
- +14 ; If multiple profile then ask which profile
- +15 SET B=$ORDER(^LRO(68.2,LRLL,10,LRPROF))
- +16 IF B>0
- SET DIC="^LRO(68.2,"_LRLL_",10,"
- DO ^DIC
- if Y<1
- GOTO LREND
- SET LRPROF=+Y
- +17 SET LRPANEL=$PIECE(^LRO(68.2,LRLL,10,LRPROF,0),U,1)
- SET LRLIST=$ORDER(^LRO(68.2,LRLL,1,LRPROF,1,0))
- +18 ;
- +19 WRITE !
- +20 ;
- +21 ; Select performing laboratory to use
- +22 IF '$DATA(LRGVP)
- Begin DoDot:1
- +23 NEW X,LRX
- +24 SET X=$PIECE(^LRO(68.2,LRLL,10,LRPROF,0),"^",5)
- +25 SET LRX=$$SELPL^LRVERA($SELECT(X:X,1:DUZ(2)))
- +26 IF LRX<1
- DO LREND
- QUIT
- +27 IF LRX
- IF LRX'=DUZ(2)
- SET LRDUZ(2)=LRX
- End DoDot:1
- +28 ;
- +29 DO EXPLODE
- +30 IF $ORDER(LRVTS(0))<1
- DO LREND
- QUIT
- +31 ;
- +32 SET I=0
- +33 FOR
- SET I=$ORDER(LRORD(I))
- if I<1
- QUIT
- SET J=LRORD(I)
- SET X=$PIECE(^LAB(60,J,0),U,5)
- SET LRORD(I)=$PIECE(X,";",2)
- +34 ;
- +35 KILL LRAA
- +36 IF $LENGTH($PIECE(^LRO(68.2,LRLL,10,LRPROF,0),U,2))
- SET LRAA=$PIECE(^(0),U,2)
- SET LRNAME=$PIECE(^LRO(68,LRAA,0),U,1)
- +37 ;
- +38 IF '$DATA(LRAA)
- Begin DoDot:1
- +39 SET DIC="^LRO(68,"
- SET DIC(0)="AEMOQ"
- +40 DO ^DIC
- +41 SET LRAA=+Y
- SET LRNAME=$PIECE(Y,U,2)
- +42 IF LRAA<1
- DO LREND
- End DoDot:1
- if LRAA<1
- QUIT
- +43 IF $PIECE(LRPARAM,U,14)
- IF $PIECE($GET(^LRO(68,LRAA,0)),U,16)
- DO AUTO^LRCAPV
- +44 IF LREND
- QUIT
- +45 ;
- +46 ; If "VERIFY BY" field empty then ask user
- +47 IF LRWT=""
- Begin DoDot:1
- +48 NEW DA,DIR,DIRUT,DTOUT,DUOUT,X,Y
- +49 SET DIR(0)="68.2,.08"
- +50 DO ^DIR
- +51 IF $DATA(DIRUT)
- DO LREND
- QUIT
- +52 SET LRWT=Y
- End DoDot:1
- if LREND
- QUIT
- +53 ;
- +54 if LRWT="A"
- DO ACC
- if LRWT="T"
- DO TRAY
- if LRWT="M"
- DO MACHSQ
- if LRWT="W"
- DO WRKLST
- +55 QUIT
- +56 ;
- +57 ;
- LREND ;
- +1 SET LREND=1
- +2 QUIT
- +3 ;
- +4 ;
- ACC ; Select accession date to verify
- +1 ;
- +2 NEW %DT,LRLAN
- +3 ;
- +4 SET LRVBY=1
- +5 ; Only ask if verifying, not group printing (LRGP)
- +6 IF '$DATA(LRGVP)
- Begin DoDot:1
- +7 SET LRVBY=$$SELBY^LRWU4("Verify by")
- +8 IF LRVBY=0
- DO LREND
- End DoDot:1
- +9 IF LREND
- QUIT
- +10 IF LRVBY=2
- QUIT
- +11 ;
- +12 ; Select accession date
- +13 DO ADATE^LRWU
- +14 IF LREND
- QUIT
- +15 ;
- +16 ; Select starting and ending accession numbers
- +17 DO LRAN^LRWU3
- +18 IF LREND
- QUIT
- +19 SET LRFAN=LRFAN-1
- SET LRLIX=LRLAN
- +20 QUIT
- +21 ;
- +22 ;
- TRAY ; Select starting and ending tray/cup
- +1 ;
- +2 NEW DIR,DIRUT,DTOUT,DUOUT,X,Y
- +3 ;
- +4 ; Find existing first and last trays on loadlist
- +5 SET LRFTRAY=$ORDER(^LRO(68.2,LRLL,1,0))
- +6 IF 'LRFTRAY
- SET LRFTRAY=1
- +7 SET LRLTRAY=$ORDER(^LRO(68.2,LRLL,1,""),-1)
- +8 IF 'LRLTRAY
- SET LRLTRAY=LRFTRAY
- +9 ;
- +10 ; Find existing first and last cups on loadlist
- +11 SET LRFCUP=$ORDER(^LRO(68.2,LRLL,1,LRFTRAY,1,0))
- +12 IF 'LRFCUP
- SET LRFCUP=1
- +13 SET LRLCUP=$ORDER(^LRO(68.2,LRLL,1,LRLTRAY,1,""),-1)
- +14 IF 'LRLCUP
- SET LRLCUP=LRMAXCUP
- +15 ;
- +16 SET DIR(0)="NO^1:9999999:0"
- SET DIR("A")="Starting tray"
- SET DIR("B")=1
- +17 DO ^DIR
- +18 IF $DATA(DIRUT)
- DO LREND
- QUIT
- +19 SET LRFTRAY=Y
- +20 ;
- +21 SET DIR(0)="NO^1:9999999:0"
- SET DIR("A")="Starting cup"
- SET DIR("B")=1
- +22 DO ^DIR
- +23 IF $DATA(DIRUT)
- DO LREND
- QUIT
- +24 SET LRFCUP=Y
- +25 ;
- +26 SET DIR(0)="NO^"_LRFTRAY_":"_LRLTRAY_":0"
- SET DIR("A")="Ending tray"
- SET DIR("B")=LRLTRAY
- +27 DO ^DIR
- +28 IF $DATA(DIRUT)
- DO LREND
- QUIT
- +29 SET LRLTRAY=Y
- +30 ;
- +31 SET DIR(0)="NO^"_LRFCUP_":"_LRLCUP_":0"
- SET DIR("A")="Ending cup"
- SET DIR("B")=LRLCUP
- +32 DO ^DIR
- +33 IF $DATA(DIRUT)
- DO LREND
- QUIT
- +34 SET LRLCUP=Y
- +35 ;
- +36 QUIT
- +37 ;
- +38 ;
- MACHSQ ; Select starting and ending machine sequence
- +1 ;
- +2 NEW DIR,DIRUT,DTOUT,DUOUT,X,Y
- +3 ;
- +4 SET DIR(0)="NO^1:9999999:0"
- SET DIR("A")="Starting sequence number"
- SET DIR("B")=1
- +5 DO ^DIR
- +6 IF $DATA(DIRUT)
- DO LREND
- QUIT
- +7 SET LRSQ=Y
- +8 ;
- +9 SET DIR(0)="NO^1:9999999:0"
- SET DIR("A")="Ending sequence number"
- SET DIR("B")=9999999
- +10 DO ^DIR
- +11 IF $DATA(DIRUT)
- DO LREND
- QUIT
- +12 SET LRESEQ=Y
- +13 QUIT
- +14 ;
- +15 ;
- WRKLST ; Select starting and ending worklist numbers
- +1 ;
- +2 NEW DIR,DIRUT,DTOUT,DUOUT,X,Y
- +3 ;
- +4 SET DIR(0)="NO^1:9999999:0"
- SET DIR("A")="Starting worklist number"
- SET DIR("B")=1
- +5 DO ^DIR
- +6 IF $DATA(DIRUT)
- DO LREND
- QUIT
- +7 SET LRCUP=Y
- +8 ;
- +9 SET DIR(0)="NO^1:9999999:0"
- SET DIR("A")="Ending worklist number"
- SET DIR("B")=9999999
- +10 DO ^DIR
- +11 IF $DATA(DIRUT)
- DO LREND
- QUIT
- +12 SET LRECUP=Y
- +13 QUIT
- +14 ;
- +15 ;
- EXPLODE ;
- +1 KILL LRORD
- +2 DO EXPLODE^LRGP2
- +3 QUIT