Routine: LR52IHS

LR52IHS ; IHS/DIR/FJE - IHS/ANMC/CLS - NEW PERSON CONVERSION FOR V LAB ; [ 1/23/91 ]

 ;;5.2;LR;;NOV 01, 1997

 ;;5.2;LAB SERVICE;;Sep 27, 1994

EN ;

 Q:'$D(ZTQUEUED)

 N D0,D1,D2,LRFLD,LRFILE,LRTSK

 S LRFILE="V-LAB",LRTSK=$G(ZTSK)

 ;  ^XTMP("LR52","V-LAB",0) is the last record converted successfully

 I '$D(^XTMP("LR52",LRFILE,0))#2&(^DD(9000010.09,0,"VR")>5.15) Q

EN1 ;

 I '$D(^XTMP("LR52",LRFILE,0))#2 S ^XTMP("LR52",LRFILE,0)=0

 S D0=$G(^XTMP("LR52",LRFILE,0)),^XTMP("LR52TIME",LRFILE)=$$NOW^LR52CNV1

 F  S D0=$O(^AUPNVLAB(D0)) Q:'D0  D A1 S D1=0 F  S D1=$O(^LRD(65,D0,2,D1)) Q:'D1  S D2=0 F  S D2=$O(^LRD(65,D0,2,D1,1,D2)) S:'D2 ^XTMP("LR52",LRFILE,0)=D0 Q:'D2  D A2

 S $P(^XTMP("LR52TIME",LRFILE),U,2)=$$NOW^LR52CNV1

 D OUT

A2 ; Change PROVIDER NUMBER field .08, subfile 65.02

 ; sub file of the PATIENT XMATCHED/ASSIGNED subfile

 S LRSB(0)=2,LRSB(1)=1

 S LRPRV=$P($G(^LRD(65,D0,2,D1,1,D2,0)),U,8) I LRPRV S LRPRV=$$PROV^LR52CNV0("65.02,.08",LRPRV,.LRSB) W !,LRPRV ; testing code

 ;S LRPRV=$P($G(^LRD(65,D0,2,D1,1,D2,0)),U,8) I LRPRV S $P(^LRD(65,D0,2,D1,1,D2,0),U,8)=$$PROV^LR52CNV0("65.02,.08",LRPRV,.LRSB)

A1 ; subscript (6) Change PROVIDER NUMBER field 6.6

 ;S LRPRV=$P($G(^LRD(65,D0,6)),U,6) I LRPRV W !,$$PROV^LR52CNV0("6.6",LRPRV,.LRSB) ;testing code

 S LRPRV=$P($G(^LRD(65,D0,6)),U,6) I LRPRV S $P(^LRD(65,D0,6),U,6)=$$PROV^LR52CNV0("6.6",LRPRV,.LRSB)

OUT ;

 I $D(LRIO) D REQUE Q

REENT ; re-entry for reque if LRIO is busy from above

 D HEAD^LR52CNV0(LRFILE)

 I '$O(^XTMP("LR52",LRFILE,0)) W !!?(IOM-$L("****  none found ****"))\2,"**** NONE FOUND ****" G END

 F LRD0=0:0 S LRD0=$O(^XTMP("LR52",LRFILE,LRD0)) Q:LRD0'>0  F LRD1=0:0 S LRD1=$O(^XTMP("LR52",LRFILE,LRD0,2,LRD1)) Q:LRD1'>0  F LRD2=0:0 S LRD2=$O(^XTMP("LR52",LRFILE,LRD0,2,LRD1,1,LRD2)) Q:LRD2'>0  D WRITE

END W @IOF D ^%ZISC K LRD0,LRD1,LRD2,LRFILE,LRFLD,LRTIT,LRVL,ZTSK,LRTSK

WRITE ;

 S LRFLD=$O(^XTMP("LR52",LRFILE,LRD0,2,LRD1,1,LRD2,0)),LRVL=$G(^XTMP("LR52",LRFILE,LRD0,2,LRD1,1,LRD2,LRFLD))

 I LRFLD["," S LRTIT=$P($G(@("^DD("_LRFLD_",0)")),U)

 I LRFLD'["," S LRTIT=$P($G(@("^DD("_$P(LRFILE,"-",2)_","_LRFLD_",0)")),U)

 S LRD0(0)=$G(^LRD(65,LRD0,0)),LRD1(0)=$G(^LRD(65,LRD0,2,LRD1,0)),LRD2(0)=$G(^LRD(65,LRD0,2,LRD1,1,LRD2,0))

 I ($Y+10)>IOSL D HEAD^LR52CNV0(LRFILE)

 W !!!,"The value ("_+LRVL_") """_$P(LRVL,U,2)_""",",!,"in field "_LRTIT_", could not be repointed.",!,"This occurred in:",LRD0,!,"The BLOOD SAMPLE DATE/TIME: subfile of",?54,"entry: "_$P(LRD2(0),U)

 W !,"The PATIENT XMATCHED/ASSIGNED: subfile of",?54,"entry: "_$P(LRD1(0),U)

 W !,"The BLOOD INVENTORY FILE:",?54,"entry: "_$P(LRD0(0),U)

REQUE ; reque task to print out exceptions

 S ZTIO=LRIO,ZTDESC="Requeue of exception report FILE 65 conversion",ZTDTH=$H,ZTRTN="REENT^LR52CNV5"

 S ZTSAVE("LRFILE")="",ZTSAVE("LRTSK")=""

 D ^%ZTLOAD Q

LR52IHS   ; IHS/DIR/FJE - IHS/ANMC/CLS - NEW PERSON CONVERSION FOR V LAB ; [ 1/23/91 ]

 +1       ;;5.2;LR;;NOV 01, 1997

 +2       ;

 +3       ;;5.2;LAB SERVICE;;Sep 27, 1994

 +4       ;

EN        ;

 +1        IF '$DATA(ZTQUEUED)

               QUIT

 +2        NEW D0,D1,D2,LRFLD,LRFILE,LRTSK

 +3        SET LRFILE="V-LAB"

           SET LRTSK=$GET(ZTSK)

 +4       ;  ^XTMP("LR52","V-LAB",0) is the last record converted successfully

 +5        IF '$DATA(^XTMP("LR52",LRFILE,0))#2&(^DD(9000010.09,0,"VR")>5.15)

               QUIT

EN1       ;

 +1        IF '$DATA(^XTMP("LR52",LRFILE,0))#2

               SET ^XTMP("LR52",LRFILE,0)=0

 +2        SET D0=$GET(^XTMP("LR52",LRFILE,0))

           SET ^XTMP("LR52TIME",LRFILE)=$$NOW^LR52CNV1

 +3        FOR

               SET D0=$ORDER(^AUPNVLAB(D0))

               IF 'D0

                   QUIT

               DO A1

               SET D1=0

FOR

                   SET D1=$ORDER(^LRD(65,D0,2,D1))

                   IF 'D1

                       QUIT

                   SET D2=0

FOR

                       SET D2=$ORDER(^LRD(65,D0,2,D1,1,D2))

                       IF 'D2

                           SET ^XTMP("LR52",LRFILE,0)=D0

                       IF 'D2

                           QUIT

                       DO A2

 +4        SET $PIECE(^XTMP("LR52TIME",LRFILE),U,2)=$$NOW^LR52CNV1

 +5        DO OUT

 +6        QUIT

 +7       ;

A2        ; Change PROVIDER NUMBER field .08, subfile 65.02

 +1       ; sub file of the PATIENT XMATCHED/ASSIGNED subfile

 +2       ;

 +3        SET LRSB(0)=2

           SET LRSB(1)=1

 +4       ; testing code

           SET LRPRV=$PIECE($GET(^LRD(65,D0,2,D1,1,D2,0)),U,8)

           IF LRPRV

               SET LRPRV=$$PROV^LR52CNV0("65.02,.08",LRPRV,.LRSB)

               WRITE !,LRPRV

 +5       ;S LRPRV=$P($G(^LRD(65,D0,2,D1,1,D2,0)),U,8) I LRPRV S $P(^LRD(65,D0,2,D1,1,D2,0),U,8)=$$PROV^LR52CNV0("65.02,.08",LRPRV,.LRSB)

 +6        QUIT

 +7       ;

A1        ; subscript (6) Change PROVIDER NUMBER field 6.6

 +1       ;S LRPRV=$P($G(^LRD(65,D0,6)),U,6) I LRPRV W !,$$PROV^LR52CNV0("6.6",LRPRV,.LRSB) ;testing code

 +2        SET LRPRV=$PIECE($GET(^LRD(65,D0,6)),U,6)

           IF LRPRV

               SET $PIECE(^LRD(65,D0,6),U,6)=$$PROV^LR52CNV0("6.6",LRPRV,.LRSB)

 +3        QUIT

 +4       ;

OUT       ;

 +1        IF $DATA(LRIO)

               DO REQUE

               QUIT

 +2       ;

REENT     ; re-entry for reque if LRIO is busy from above

 +1       ;

 +2        DO HEAD^LR52CNV0(LRFILE)

 +3        IF '$ORDER(^XTMP("LR52",LRFILE,0))

               WRITE !!?(IOM-$LENGTH("****  none found ****"))\2,"**** NONE FOUND ****"

               GOTO END

 +4        FOR LRD0=0:0

               SET LRD0=$ORDER(^XTMP("LR52",LRFILE,LRD0))

               IF LRD0'>0

                   QUIT

               FOR LRD1=0:0

                   SET LRD1=$ORDER(^XTMP("LR52",LRFILE,LRD0,2,LRD1))

                   IF LRD1'>0

                       QUIT

                   FOR LRD2=0:0

                       SET LRD2=$ORDER(^XTMP("LR52",LRFILE,LRD0,2,LRD1,1,LRD2))

                       IF LRD2'>0

                           QUIT

                       DO WRITE

END        WRITE @IOF

           DO ^%ZISC

           KILL LRD0,LRD1,LRD2,LRFILE,LRFLD,LRTIT,LRVL,ZTSK,LRTSK

 +1        QUIT

 +2       ;

WRITE     ;

 +1        SET LRFLD=$ORDER(^XTMP("LR52",LRFILE,LRD0,2,LRD1,1,LRD2,0))

           SET LRVL=$GET(^XTMP("LR52",LRFILE,LRD0,2,LRD1,1,LRD2,LRFLD))

 +2        IF LRFLD[","

               SET LRTIT=$PIECE($GET(@("^DD("_LRFLD_",0)")),U)

 +3        IF LRFLD'[","

               SET LRTIT=$PIECE($GET(@("^DD("_$PIECE(LRFILE,"-",2)_","_LRFLD_",0)")),U)

 +4        SET LRD0(0)=$GET(^LRD(65,LRD0,0))

           SET LRD1(0)=$GET(^LRD(65,LRD0,2,LRD1,0))

           SET LRD2(0)=$GET(^LRD(65,LRD0,2,LRD1,1,LRD2,0))

 +5        IF ($Y+10)>IOSL

               DO HEAD^LR52CNV0(LRFILE)

 +6        WRITE !!!,"The value ("_+LRVL_") """_$PIECE(LRVL,U,2)_""",",!,"in field "_LRTIT_", could not be repointed.",!,"This occurred in:",LRD0,!,"The BLOOD SAMPLE DATE/TIME: subfile of",?54,"entry: "_$PIECE(LRD2(0),U)

 +7        WRITE !,"The PATIENT XMATCHED/ASSIGNED: subfile of",?54,"entry: "_$PIECE(LRD1(0),U)

 +8        WRITE !,"The BLOOD INVENTORY FILE:",?54,"entry: "_$PIECE(LRD0(0),U)

 +9        QUIT

 +10      ;

REQUE     ; reque task to print out exceptions

 +1        SET ZTIO=LRIO

           SET ZTDESC="Requeue of exception report FILE 65 conversion"

           SET ZTDTH=$HOROLOG

           SET ZTRTN="REENT^LR52CNV5"

 +2        SET ZTSAVE("LRFILE")=""

           SET ZTSAVE("LRTSK")=""

 +3        DO ^%ZTLOAD

           QUIT

LR52IHS.m