LRCAPFDS.m

LRCAPFDS ;VA/DALOI/FHS - EDIT ACTIVATED WKLD CODES BY WKLD LAB SECTION ;5/1/99

 ;;5.2;LAB SERVICE;**1002,1031**;NOV 1, 1997

 ;

 ;;VA LR Patche(s): 105,119,127,163,274,362

 ;

EN ;

 K ^TMP("LRLAM",DUZ_$J),DIR W !

 S DIR("?")="Select any individual WKLD CODE then edit all fields"

 S DIR("A")="Do you want to edit specific WKLD CODES/ALL fields? "

 S DIR(0)="Y",DIR("B")="N" D ^DIR G:$D(DIRUT) END

 I Y=1 D  G END

 . F  W ! K DIC S DIC=64,DIC(0)="AQEZNM" D ^DIC Q:Y<1  D

 . . N DA,DIE,DR

 . . S DA=+Y,DR="[LR WKLD EDIT ALL]",DIE="^LAM(" D ^DIE

 I '$O(^LAM("AC",1,0)) W !?5,"You have no Activated WKLD CODES ",! G END

 W !?5,"This option will allow you to Edit or Print WKLD CODES"

 K DIR,LRSECT S DIR("A")="Do you want to select a specific WKLD CODE LAB SECTION"

 S DIR(0)="Y",DIR("B")="Y" D ^DIR G:$D(DIRUT) END

 I Y K DIC,DIR S DIC=64.21,DIC(0)="AEQZNM" D ^DIC G:Y<1 END S LRSECT=+Y

 K DIR,DIC S DIR(0)="S^E:EDIT;P:PRINT",DIR("A")="Would you like to"

 D ^DIR G END:$D(DIRUT) G:Y="P" PRINT

EDIT ;

 W !,"EDITING",! K DIR

 S DIR(0)="S,O^1:ALL;.02:DESCRIPT;4:BILLABLE PROCEDURE;7:COST;8:PRICE;9:SORTING GROUP;13:WKLD CODE LAB SECTION;14:DSS Feeder;18:CODE;19:SYNONYM;20:SPECIMEN;21:LOCAL ACC AREA;26:ES DISPLAY ORDER"

 S DIR("A")="Select a field you want to edit ",LRDR=""

ASK D ^DIR G:X=U END I Y=1 S LRDR="[LR WKLD EDIT ALL]" D LRSET G ALL

 I Y S LRDR=LRDR_Y_";" S DIR("A")="Select Another Field " G ASK

 I '$L(LRDR) W !?5,"Nothing Selected ",! G END

 S LRDR=$E(LRDR,1,($L(LRDR)-1))

 D LRSET

ALL I '$D(^TMP("LRLAM",DUZ_$J)) W !!,$$CJ^XLFSTR(" Database scan was negative.",80),!,$$CJ^XLFSTR(" No WKLD CODES assigned to WKLD CODE LAB SECTION you selected.",80),$C(7),! G END

 K DIR S DIR(0)="F^1:60",DIR("A")="Start with what WKLD CODE name",DIR("A",2)="Use mixed case Characters e.g Chloride "

 S DIR("A",1)=""

 D ^DIR G:$D(DIRUT) END

 S LRWKLD=X W !,"STARTING LOOP ",!

LOOP ;

 S LRWKLD=$O(^TMP("LRLAM",DUZ_$J,$E(LRWKLD,1,$L(LRWKLD)-1))),LRNN=DUZ_$J

 I LRWKLD="" W !!?5,"Nothing matches your criteria",! G END

 S LRNODE="^TMP(""LRLAM"","_DUZ_$J_","""_LRWKLD_""",0)",LREND=0 W @IOF

 F  S LRNODE=$Q(@LRNODE) Q:$QS(LRNODE,2)'=LRNN!($G(LREND))  S DA=+$QS(LRNODE,4) I DA D

 . D DIQ S:$G(DIRUT) LREND=1 Q:LREND=1  S S=0,DR=LRDR,DIE=64 D ^DIE S:$D(Y)!(X="^") LREND=1

 G END

 Q

PRINT ;

 K DIR S DIR(0)="Y",DIR("B")="Y",DIR("A")="Would you like only CPT linked WKLD CODES" D ^DIR G:$D(DIRUT) END

 S LRCPT=Y

 W !,"PRINT",! K %ZIS S %ZIS="QN" D ^%ZIS G:POP END

 I IO'=IO(0) D  D ^%ZISC G END

 . S:$G(LRSECT) ZTSAVE("LRSECT")="" S ZTRTN="DQ^LRCAPFDS",ZTSAVE("LRCPT")="",ZTIO=ION

 . K ZTSK D ^%ZTLOAD W:$G(ZTSK) !?5,"Report Queued to "_ION I '$G(ZTSK) W !!?10,"**** Report Not Queued ****",!

DQ ;

 S:$D(ZTQUEUED) ZTREQ="@" D LRSET

 I '$D(^TMP("LRLAM",DUZ_$J)) W !!?10," Database scan was negative.",!," No WKLD CODES assigned to WKLD CODE LAB SECTION you selected.",! G END

 S S=5,LRNODE="^TMP(""LRLAM"","_DUZ_$J_",0)",DIC="^LAM(",DR="0:99",LREND=0

 K DIR S LRNN=DUZ_$J D HEAD

 F  S LRNODE=$Q(@LRNODE) Q:$QS(LRNODE,2)'=LRNN!($G(LREND))  S DA=+$QS(LRNODE,4) I DA D

 . D EN^LRDIQ S:$D(DIRUT) LREND=1 S S=S+2 S:$E(IOST,1,2)'="C-" S=0

 Q

END ;

 W ! W:$E(IOST,1,2)="P-" @IOF D ^%ZISC

 K DA,DIC,DIE,DIR,DR,DTOUT,DUOUT,DIRUT

 K LRDAT,LREND,LRN,LRNN,LRNODE,LRSECT,LRTIT,LRWKLD,S

 K X,Y,LRDR,ZTSK,%ZIS,DIRUT,LRCPT

 Q

HEAD ;

 W !!,$$CJ^XLFSTR("Activated WKLD Codes",IOM),!

 S LRTIT=" WKLD LAB SECTION [ "_$S($D(^LAB(64.21,+$G(LRSECT),0)):$P(^(0),U),1:"** ALL **")_" ]"

 S LRDAT=$$HTE^XLFDT($H),S=6

 W $$CJ^XLFSTR(LRTIT,IOM),!,$$CJ^XLFSTR(LRDAT,IOM),!

 Q

DIQ ;

 Q:'$G(DA)  W ! S DIC="^LAM(",DR=0 D EN^LRDIQ

 Q

LRSET ;

 S LRN=0 F  S LRN=$O(^LAM(LRN)) Q:LRN<1  I $D(^LAM(LRN,0))#2 S LRNODE=^(0) D

 . I $G(LRSECT),$P(LRNODE,U,15)'=LRSECT Q

 . I $G(LRCPT),'$O(^LAM(LRN,4,0)) Q

 . S ^TMP("LRLAM",DUZ_$J,$P(LRNODE,U),LRN)=$P(LRNODE,U,2)

 Q

LRCAPFDS  ;VA/DALOI/FHS - EDIT ACTIVATED WKLD CODES BY WKLD LAB SECTION ;5/1/99

 +1       ;;5.2;LAB SERVICE;**1002,1031**;NOV 1, 1997

 +2       ;

 +3       ;;VA LR Patche(s): 105,119,127,163,274,362

 +4       ;

EN        ;

 +1        KILL ^TMP("LRLAM",DUZ_$JOB),DIR

           WRITE !

 +2        SET DIR("?")="Select any individual WKLD CODE then edit all fields"

 +3        SET DIR("A")="Do you want to edit specific WKLD CODES/ALL fields? "

 +4        SET DIR(0)="Y"

           SET DIR("B")="N"

           DO ^DIR

           IF $DATA(DIRUT)

               GOTO END

 +5        IF Y=1

               Begin DoDot:1

 +6                FOR 

                       WRITE !

                       KILL DIC

                       SET DIC=64

                       SET DIC(0)="AQEZNM"

                       DO ^DIC

                       IF Y<1

                           QUIT 

                       Begin DoDot:2

 +7                        NEW DA,DIE,DR

 +8                        SET DA=+Y

                           SET DR="[LR WKLD EDIT ALL]"

                           SET DIE="^LAM("

                           DO ^DIE

                       End DoDot:2

               End DoDot:1

               GOTO END

 +9        IF '$ORDER(^LAM("AC",1,0))

               WRITE !?5,"You have no Activated WKLD CODES ",!

               GOTO END

 +10       WRITE !?5,"This option will allow you to Edit or Print WKLD CODES"

 +11       KILL DIR,LRSECT

           SET DIR("A")="Do you want to select a specific WKLD CODE LAB SECTION"

 +12       SET DIR(0)="Y"

           SET DIR("B")="Y"

           DO ^DIR

           IF $DATA(DIRUT)

               GOTO END

 +13       IF Y

               KILL DIC,DIR

               SET DIC=64.21

               SET DIC(0)="AEQZNM"

               DO ^DIC

               IF Y<1

                   GOTO END

               SET LRSECT=+Y

 +14       KILL DIR,DIC

           SET DIR(0)="S^E:EDIT;P:PRINT"

           SET DIR("A")="Would you like to"

 +15       DO ^DIR

           IF $DATA(DIRUT)

               GOTO END

           IF Y="P"

               GOTO PRINT

EDIT      ;

 +1        WRITE !,"EDITING",!

           KILL DIR

 +2        SET DIR(0)="S,O^1:ALL;.02:DESCRIPT;4:BILLABLE PROCEDURE;7:COST;8:PRICE;9:SORTING GROUP;13:WKLD CODE LAB SECTION;14:DSS Feeder;18:CODE;19:SYNONYM;20:SPECIMEN;21:LOCAL ACC AREA;26:ES DISPLAY ORDER"

 +3        SET DIR("A")="Select a field you want to edit "

           SET LRDR=""

ASK        DO ^DIR

           IF X=U

               GOTO END

           IF Y=1

               SET LRDR="[LR WKLD EDIT ALL]"

               DO LRSET

               GOTO ALL

 +1        IF Y

               SET LRDR=LRDR_Y_";"

               SET DIR("A")="Select Another Field "

               GOTO ASK

 +2        IF '$LENGTH(LRDR)

               WRITE !?5,"Nothing Selected ",!

               GOTO END

 +3        SET LRDR=$EXTRACT(LRDR,1,($LENGTH(LRDR)-1))

 +4        DO LRSET

ALL        IF '$DATA(^TMP("LRLAM",DUZ_$JOB))

               WRITE !!,$$CJ^XLFSTR(" Database scan was negative.",80),!,$$CJ^XLFSTR(" No WKLD CODES assigned to WKLD CODE LAB SECTION you selected.",80),$CHAR(7),!

               GOTO END

 +1        KILL DIR

           SET DIR(0)="F^1:60"

           SET DIR("A")="Start with what WKLD CODE name"

           SET DIR("A",2)="Use mixed case Characters e.g Chloride "

 +2        SET DIR("A",1)=""

 +3        DO ^DIR

           IF $DATA(DIRUT)

               GOTO END

 +4        SET LRWKLD=X

           WRITE !,"STARTING LOOP ",!

LOOP      ;

 +1        SET LRWKLD=$ORDER(^TMP("LRLAM",DUZ_$JOB,$EXTRACT(LRWKLD,1,$LENGTH(LRWKLD)-1)))

           SET LRNN=DUZ_$JOB

 +2        IF LRWKLD=""

               WRITE !!?5,"Nothing matches your criteria",!

               GOTO END

 +3        SET LRNODE="^TMP(""LRLAM"","_DUZ_$JOB_","""_LRWKLD_""",0)"

           SET LREND=0

           WRITE @IOF

 +4        FOR 

               SET LRNODE=$QUERY(@LRNODE)

               IF $QSUBSCRIPT(LRNODE,2)'=LRNN!($GET(LREND))

                   QUIT 

               SET DA=+$QSUBSCRIPT(LRNODE,4)

               IF DA

                   Begin DoDot:1

 +5                    DO DIQ

                       IF $GET(DIRUT)

                           SET LREND=1

                       IF LREND=1

                           QUIT 

                       SET S=0

                       SET DR=LRDR

                       SET DIE=64

                       DO ^DIE

                       IF $DATA(Y)!(X="^")

                           SET LREND=1

                   End DoDot:1

 +6        GOTO END

 +7        QUIT 

PRINT     ;

 +1        KILL DIR

           SET DIR(0)="Y"

           SET DIR("B")="Y"

           SET DIR("A")="Would you like only CPT linked WKLD CODES"

           DO ^DIR

           IF $DATA(DIRUT)

               GOTO END

 +2        SET LRCPT=Y

 +3        WRITE !,"PRINT",!

           KILL %ZIS

           SET %ZIS="QN"

           DO ^%ZIS

           IF POP

               GOTO END

 +4        IF IO'=IO(0)

               Begin DoDot:1

 +5                IF $GET(LRSECT)

                       SET ZTSAVE("LRSECT")=""

                   SET ZTRTN="DQ^LRCAPFDS"

                   SET ZTSAVE("LRCPT")=""

                   SET ZTIO=ION

 +6                KILL ZTSK

                   DO ^%ZTLOAD

                   IF $GET(ZTSK)

                       WRITE !?5,"Report Queued to "_ION

                   IF '$GET(ZTSK)

                       WRITE !!?10,"**** Report Not Queued ****",!

               End DoDot:1

               DO ^%ZISC

               GOTO END

DQ        ;

 +1        IF $DATA(ZTQUEUED)

               SET ZTREQ="@"

           DO LRSET

 +2        IF '$DATA(^TMP("LRLAM",DUZ_$JOB))

               WRITE !!?10," Database scan was negative.",!," No WKLD CODES assigned to WKLD CODE LAB SECTION you selected.",!

               GOTO END

 +3        SET S=5

           SET LRNODE="^TMP(""LRLAM"","_DUZ_$JOB_",0)"

           SET DIC="^LAM("

           SET DR="0:99"

           SET LREND=0

 +4        KILL DIR

           SET LRNN=DUZ_$JOB

           DO HEAD

 +5        FOR 

               SET LRNODE=$QUERY(@LRNODE)

               IF $QSUBSCRIPT(LRNODE,2)'=LRNN!($GET(LREND))

                   QUIT 

               SET DA=+$QSUBSCRIPT(LRNODE,4)

               IF DA

                   Begin DoDot:1

 +6                    DO EN^LRDIQ

                       IF $DATA(DIRUT)

                           SET LREND=1

                       SET S=S+2

                       IF $EXTRACT(IOST,1,2)'="C-"

                           SET S=0

                   End DoDot:1

 +7        QUIT 

END       ;

 +1        WRITE !

           IF $EXTRACT(IOST,1,2)="P-"

               WRITE @IOF

           DO ^%ZISC

 +2        KILL DA,DIC,DIE,DIR,DR,DTOUT,DUOUT,DIRUT

 +3        KILL LRDAT,LREND,LRN,LRNN,LRNODE,LRSECT,LRTIT,LRWKLD,S

 +4        KILL X,Y,LRDR,ZTSK,%ZIS,DIRUT,LRCPT

 +5        QUIT 

HEAD      ;

 +1        WRITE !!,$$CJ^XLFSTR("Activated WKLD Codes",IOM),!

 +2        SET LRTIT=" WKLD LAB SECTION [ "_$SELECT($DATA(^LAB(64.21,+$GET(LRSECT),0)):$PIECE(^(0),U),1:"** ALL **")_" ]"

 +3        SET LRDAT=$$HTE^XLFDT($HOROLOG)

           SET S=6

 +4        WRITE $$CJ^XLFSTR(LRTIT,IOM),!,$$CJ^XLFSTR(LRDAT,IOM),!

 +5        QUIT 

DIQ       ;

 +1        IF '$GET(DA)

               QUIT 

           WRITE !

           SET DIC="^LAM("

           SET DR=0

           DO EN^LRDIQ

 +2        QUIT 

LRSET     ;

 +1        SET LRN=0

           FOR 

               SET LRN=$ORDER(^LAM(LRN))

               IF LRN<1

                   QUIT 

               IF $DATA(^LAM(LRN,0))#2

                   SET LRNODE=^(0)

                   Begin DoDot:1

 +2                    IF $GET(LRSECT)

                           IF $PIECE(LRNODE,U,15)'=LRSECT

                               QUIT 

 +3                    IF $GET(LRCPT)

                           IF '$ORDER(^LAM(LRN,4,0))

                               QUIT 

 +4                    SET ^TMP("LRLAM",DUZ_$JOB,$PIECE(LRNODE,U),LRN)=$PIECE(LRNODE,U,2)

                   End DoDot:1

 +5        QUIT