LRGP1.m

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 ---LRGP1   3804     printed  Oct 16, 2024@18:15:41                                                                                                                                                                                                       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