source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRCAPF.m@ 619

Last change on this file since 619 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.2 KB
Line 
1LRCAPF ;DALISC/FHS-STUFF WKLD CODE INTO FILE 60 61.2 62.07 ETC ;5/2/91 09:03
2 ;;5.2;LAB SERVICE;**221**;Sep 27, 1994
3EN ;
4 L +^LRO(61.2):1 I '$T W !,$C(7),"Someone else is editing ^LRO(61.2) file ",! Q
5DOC ;
6 W !!,$$CJ^XLFSTR("You must have already defined and ran a search template for the",IOM)
7 W !,$$CJ^XLFSTR("ETIOLOGY FIELD (#61.2). This option will use the results of that search",IOM)
8 W !,$$CJ^XLFSTR("and automatically stuff WKLD Codes for those organisms. If you wish to edit",IOM)
9 W !,$$CJ^XLFSTR("a single organism, use FileMan enter/edit option.",IOM)
10 W !!,$$CJ^XLFSTR("This option will automatically add WKLD codes to your",IOM)
11 W !,$$CJ^XLFSTR("ETIOLOGY FILE (#61.2).",IOM),!!
12 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
13ETIO ;
14 K DIC,LRCAPX S LRCAPX=""
15ASK W !!,?10,"Select WKLD Code(s) to be added " K DIC
16 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)
17 G END:$D(DTOUT)!($D(DUOUT))
18 I '$O(LRCAPX(0)) W !,$$CJ^XLFSTR("No WKLD Codes Selected - Continue to purge existing codes. ",IOM),!,$C(7) G PURG
19AD D SHOW
20 W !!?10,"Wish to delete any selection(s) " S %=2 D YN^DICN G AD:%=0,END:%<0,DEL:%=1
21PURG K LRPURG W !!,"Shall I purge already existing Wkld Codes " S %=2 D YN^DICN G END:%<0 S:%=1 LRPURG=1
22MULT ;
23 G:'$O(LRCAPX(0)) OK
24 R !!?10,"Multiply Factor: 1 // ",X:DTIME G END:'$T!($E(X)=U) S:X="" X=1
25 D:X'=+X!(X>20)!(X<1)!(X?.E1"."1N.N) G:'$G(X) MULT
26 . W !!,$C(7),"Enter a whole number between 1-20",! K X
27 S LRMULT=X
28OK W:$O(LRCAPX(0)) !!,$$CJ^XLFSTR("Ready to have the WKLD Codes Added to the Etiology File ",IOM)
29 W:$G(LRPURG) !!,$$CJ^XLFSTR($S($O(LRCAPX(0)):"**AND** ",1:"")_"PURGE ALREADY EXISTING WKLD CODES IN FILE",IOM),$C(7)
30 S %=2 D YN^DICN G END:%<0,EN:%'=1
31 W !!,$$CJ^XLFSTR("PRESS RETURN TO STOP PROCESS",IOM),$C(7),!! R X:2 G END:$T
32STUF K STOP,DA S DA=0 F S DA=$O(^DIBT(LRS,1,DA)) Q:DA<1!($G(LRSTOP)) D
33 . 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
34 . I $D(^LAB(61.2,DA,0))#2,$O(LRCAPX(0)) W !,"Adding WKLD Codes to : ",$P(^(0),U) D
35 . . 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
36 . . . 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 "."
37 W:$G(LRSTOP)=1 !!,$$CJ^XLFSTR("PROCESS ABORTED BEFORE UPDATE WAS COMPLETED",IOM),$C(7),!!
38 W:'$G(LRSTOP) !!,$$CJ^XLFSTR("Process complete",IOM),!
39 G END Q
40SHOW ;
41 W !!?10,"You have selected ",!!
42 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)
43 Q
44DEL ;
45 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
46 I LRDEL'=+LRDEL W !!?20,"Positive number only ",$C(7) D SHOW G DEL
47 I '$D(CNT(+LRDEL)) W !!?10,"Invalid Number Retry Please ",$C(7),! D SHOW G DEL
48 K LRCAPX(CNT(LRDEL)),CNT(LRDEL) G DEL
49END ;
50 L -^LRO(61.2)
51 Q:$G(LRDBUG)
52 K CNT,DIC,DIE,DLAYGO,DA,DR,LRCAPX,LRDEL,LRI,LRMULT,LRPURG,LRS,LRX,LRSTOP
53 Q
Note: See TracBrowser for help on using the repository browser.