LRCAPF ;DALISC/FHS-STUFF WKLD CODE INTO FILE 60 61.2 62.07 ETC ;5/2/91 09:03
;;5.2;LAB SERVICE;**221**;Sep 27, 1994
EN ;
L +^LRO(61.2):1 I '$T W !,$C(7),"Someone else is editing ^LRO(61.2) file ",! Q
DOC ;
W !!,$$CJ^XLFSTR("You must have already defined and ran a search template for the",IOM)
W !,$$CJ^XLFSTR("ETIOLOGY FIELD (#61.2). This option will use the results of that search",IOM)
W !,$$CJ^XLFSTR("and automatically stuff WKLD Codes for those organisms. If you wish to edit",IOM)
W !,$$CJ^XLFSTR("a single organism, use FileMan enter/edit option.",IOM)
W !!,$$CJ^XLFSTR("This option will automatically add WKLD codes to your",IOM)
W !,$$CJ^XLFSTR("ETIOLOGY FILE (#61.2).",IOM),!!
K DIC S DIC="^DIBT(",DIC("S")="I $P(^(0),U,4)=61.2",DIC(0)="AQENM",DIC("A")="Select Sort Template " D ^DIC G:Y<1 END S LRS=+Y
ETIO ;
K DIC,LRCAPX S LRCAPX=""
ASK W !!,?10,"Select WKLD Code(s) to be added " K DIC
S DIC="^LAM(",DIC(0)="ZAQENM",DIC("A")="Enter WKLD Code : " F D ^DIC Q:Y<1 S LRCAPX(+Y)=$P(Y(0),U)_"^"_$P(Y(0),U,2)
G END:$D(DTOUT)!($D(DUOUT))
I '$O(LRCAPX(0)) W !,$$CJ^XLFSTR("No WKLD Codes Selected - Continue to purge existing codes. ",IOM),!,$C(7) G PURG
AD D SHOW
W !!?10,"Wish to delete any selection(s) " S %=2 D YN^DICN G AD:%=0,END:%<0,DEL:%=1
PURG K LRPURG W !!,"Shall I purge already existing Wkld Codes " S %=2 D YN^DICN G END:%<0 S:%=1 LRPURG=1
MULT ;
G:'$O(LRCAPX(0)) OK
R !!?10,"Multiply Factor: 1 // ",X:DTIME G END:'$T!($E(X)=U) S:X="" X=1
D:X'=+X!(X>20)!(X<1)!(X?.E1"."1N.N) G:'$G(X) MULT
. W !!,$C(7),"Enter a whole number between 1-20",! K X
S LRMULT=X
OK W:$O(LRCAPX(0)) !!,$$CJ^XLFSTR("Ready to have the WKLD Codes Added to the Etiology File ",IOM)
W:$G(LRPURG) !!,$$CJ^XLFSTR($S($O(LRCAPX(0)):"**AND** ",1:"")_"PURGE ALREADY EXISTING WKLD CODES IN FILE",IOM),$C(7)
S %=2 D YN^DICN G END:%<0,EN:%'=1
W !!,$$CJ^XLFSTR("PRESS RETURN TO STOP PROCESS",IOM),$C(7),!! R X:2 G END:$T
STUF K STOP,DA S DA=0 F S DA=$O(^DIBT(LRS,1,DA)) Q:DA<1!($G(LRSTOP)) D
. I $G(LRPURG) W !?5,"Purging WKLD Code(s) from ",$P($G(^LAB(61.2,DA,0)),U) K ^LAB(61.2,DA,9) R LRSTOP:1 S:$T LRSTOP=1
. I $D(^LAB(61.2,DA,0))#2,$O(LRCAPX(0)) W !,"Adding WKLD Codes to : ",$P(^(0),U) D
. . F LRI=0:0 S LRI=$O(LRCAPX(LRI)) Q:LRI<1 R LRSTOP:1 S:$T LRSTOP=1 Q:$G(LRSTOP) S LRX=$P(LRCAPX(LRI),U,2) I '$D(^LAB(61.2,DA,9,LRI)) D
. . . K DIC,DR,DIE S DIC(0)="LMX",DLAYGO=61,DIC="^LAB(61.2,",DIE=DIC,DR="11///^S X=LRX",DR(2,61.211)=".01///^S X=LRX;2///^S X=LRMULT" D ^DIE K DLAYGO W "."
W:$G(LRSTOP)=1 !!,$$CJ^XLFSTR("PROCESS ABORTED BEFORE UPDATE WAS COMPLETED",IOM),$C(7),!!
W:'$G(LRSTOP) !!,$$CJ^XLFSTR("Process complete",IOM),!
G END Q
SHOW ;
W !!?10,"You have selected ",!!
K CNT S (CNT,I)=0 F S I=$O(LRCAPX(I)),CNT=CNT+1 Q:'I S CNT(CNT)=I W !,CNT,?5,$P(LRCAPX(I),U,2),?20,$P(LRCAPX(I),U)
Q
DEL ;
W !!?10,"Select a Number to delete " R LRDEL:DTIME G:'$T!($E(LRDEL)="^") END G:LRDEL="" ASK I $E(LRDEL)="?" D SHOW G DEL
I LRDEL'=+LRDEL W !!?20,"Positive number only ",$C(7) D SHOW G DEL
I '$D(CNT(+LRDEL)) W !!?10,"Invalid Number Retry Please ",$C(7),! D SHOW G DEL
K LRCAPX(CNT(LRDEL)),CNT(LRDEL) G DEL
END ;
L -^LRO(61.2)
Q:$G(LRDBUG)
K CNT,DIC,DIE,DLAYGO,DA,DR,LRCAPX,LRDEL,LRI,LRMULT,LRPURG,LRS,LRX,LRSTOP
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRCAPF 3299 printed Apr 09, 2024@21:13:02 Page 2
LRCAPF ;DALISC/FHS-STUFF WKLD CODE INTO FILE 60 61.2 62.07 ETC ;5/2/91 09:03
+1 ;;5.2;LAB SERVICE;**221**;Sep 27, 1994
EN ;
+1 LOCK +^LRO(61.2):1
IF '$TEST
WRITE !,$CHAR(7),"Someone else is editing ^LRO(61.2) file ",!
QUIT
DOC ;
+1 WRITE !!,$$CJ^XLFSTR("You must have already defined and ran a search template for the",IOM)
+2 WRITE !,$$CJ^XLFSTR("ETIOLOGY FIELD (#61.2). This option will use the results of that search",IOM)
+3 WRITE !,$$CJ^XLFSTR("and automatically stuff WKLD Codes for those organisms. If you wish to edit",IOM)
+4 WRITE !,$$CJ^XLFSTR("a single organism, use FileMan enter/edit option.",IOM)
+5 WRITE !!,$$CJ^XLFSTR("This option will automatically add WKLD codes to your",IOM)
+6 WRITE !,$$CJ^XLFSTR("ETIOLOGY FILE (#61.2).",IOM),!!
+7 KILL DIC
SET DIC="^DIBT("
SET DIC("S")="I $P(^(0),U,4)=61.2"
SET DIC(0)="AQENM"
SET DIC("A")="Select Sort Template "
DO ^DIC
if Y<1
GOTO END
SET LRS=+Y
ETIO ;
+1 KILL DIC,LRCAPX
SET LRCAPX=""
ASK WRITE !!,?10,"Select WKLD Code(s) to be added "
KILL DIC
+1 SET DIC="^LAM("
SET DIC(0)="ZAQENM"
SET DIC("A")="Enter WKLD Code : "
FOR
DO ^DIC
if Y<1
QUIT
SET LRCAPX(+Y)=$PIECE(Y(0),U)_"^"_$PIECE(Y(0),U,2)
+2 if $DATA(DTOUT)!($DATA(DUOUT))
GOTO END
+3 IF '$ORDER(LRCAPX(0))
WRITE !,$$CJ^XLFSTR("No WKLD Codes Selected - Continue to purge existing codes. ",IOM),!,$CHAR(7)
GOTO PURG
AD DO SHOW
+1 WRITE !!?10,"Wish to delete any selection(s) "
SET %=2
DO YN^DICN
if %=0
GOTO AD
if %<0
GOTO END
if %=1
GOTO DEL
PURG KILL LRPURG
WRITE !!,"Shall I purge already existing Wkld Codes "
SET %=2
DO YN^DICN
if %<0
GOTO END
if %=1
SET LRPURG=1
MULT ;
+1 if '$ORDER(LRCAPX(0))
GOTO OK
+2 READ !!?10,"Multiply Factor: 1 // ",X:DTIME
if '$TEST!($EXTRACT(X)=U)
GOTO END
if X=""
SET X=1
+3 if X'=+X!(X>20)!(X<1)!(X?.E1"."1N.N)
Begin DoDot:1
+4 WRITE !!,$CHAR(7),"Enter a whole number between 1-20",!
KILL X
End DoDot:1
if '$GET(X)
GOTO MULT
+5 SET LRMULT=X
OK if $ORDER(LRCAPX(0))
WRITE !!,$$CJ^XLFSTR("Ready to have the WKLD Codes Added to the Etiology File ",IOM)
+1 if $GET(LRPURG)
WRITE !!,$$CJ^XLFSTR($SELECT($ORDER(LRCAPX(0)):"**AND** ",1:"")_"PURGE ALREADY EXISTING WKLD CODES IN FILE",IOM),$CHAR(7)
+2 SET %=2
DO YN^DICN
if %<0
GOTO END
if %'=1
GOTO EN
+3 WRITE !!,$$CJ^XLFSTR("PRESS RETURN TO STOP PROCESS",IOM),$CHAR(7),!!
READ X:2
if $TEST
GOTO END
STUF KILL STOP,DA
SET DA=0
FOR
SET DA=$ORDER(^DIBT(LRS,1,DA))
if DA<1!($GET(LRSTOP))
QUIT
Begin DoDot:1
+1 IF $GET(LRPURG)
WRITE !?5,"Purging WKLD Code(s) from ",$PIECE($GET(^LAB(61.2,DA,0)),U)
KILL ^LAB(61.2,DA,9)
READ LRSTOP:1
if $TEST
SET LRSTOP=1
+2 IF $DATA(^LAB(61.2,DA,0))#2
IF $ORDER(LRCAPX(0))
WRITE !,"Adding WKLD Codes to : ",$PIECE(^(0),U)
Begin DoDot:2
+3 FOR LRI=0:0
SET LRI=$ORDER(LRCAPX(LRI))
if LRI<1
QUIT
READ LRSTOP:1
if $TEST
SET LRSTOP=1
if $GET(LRSTOP)
QUIT
SET LRX=$PIECE(LRCAPX(LRI),U,2)
IF '$DATA(^LAB(61.2,DA,9,LRI))
Begin DoDot:3
+4 KILL DIC,DR,DIE
SET DIC(0)="LMX"
SET DLAYGO=61
SET DIC="^LAB(61.2,"
SET DIE=DIC
SET DR="11///^S X=LRX"
SET DR(2,61.211)=".01///^S X=LRX;2///^S X=LRMULT"
DO ^DIE
KILL DLAYGO
WRITE "."
End DoDot:3
End DoDot:2
End DoDot:1
+5 if $GET(LRSTOP)=1
WRITE !!,$$CJ^XLFSTR("PROCESS ABORTED BEFORE UPDATE WAS COMPLETED",IOM),$CHAR(7),!!
+6 if '$GET(LRSTOP)
WRITE !!,$$CJ^XLFSTR("Process complete",IOM),!
+7 GOTO END
QUIT
SHOW ;
+1 WRITE !!?10,"You have selected ",!!
+2 KILL CNT
SET (CNT,I)=0
FOR
SET I=$ORDER(LRCAPX(I))
SET CNT=CNT+1
if 'I
QUIT
SET CNT(CNT)=I
WRITE !,CNT,?5,$PIECE(LRCAPX(I),U,2),?20,$PIECE(LRCAPX(I),U)
+3 QUIT
DEL ;
+1 WRITE !!?10,"Select a Number to delete "
READ LRDEL:DTIME
if '$TEST!($EXTRACT(LRDEL)="^")
GOTO END
if LRDEL=""
GOTO ASK
IF $EXTRACT(LRDEL)="?"
DO SHOW
GOTO DEL
+2 IF LRDEL'=+LRDEL
WRITE !!?20,"Positive number only ",$CHAR(7)
DO SHOW
GOTO DEL
+3 IF '$DATA(CNT(+LRDEL))
WRITE !!?10,"Invalid Number Retry Please ",$CHAR(7),!
DO SHOW
GOTO DEL
+4 KILL LRCAPX(CNT(LRDEL)),CNT(LRDEL)
GOTO DEL
END ;
+1 LOCK -^LRO(61.2)
+2 if $GET(LRDBUG)
QUIT
+3 KILL CNT,DIC,DIE,DLAYGO,DA,DR,LRCAPX,LRDEL,LRI,LRMULT,LRPURG,LRS,LRX,LRSTOP
+4 QUIT
