LRCAPFDS ;DALOI/FHS - EDIT ACTIVATED WKLD CODES BY WKLD LAB SECTION ;5/1/99
;;5.2;LAB SERVICE;**105,119,127,163,274,362**;Sep 27, 1994;Build 11
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRCAPFDS 3853 printed Nov 22, 2024@17:23:01 Page 2
LRCAPFDS ;DALOI/FHS - EDIT ACTIVATED WKLD CODES BY WKLD LAB SECTION ;5/1/99
+1 ;;5.2;LAB SERVICE;**105,119,127,163,274,362**;Sep 27, 1994;Build 11
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
