- LRCAPF ;DALISC/FHS-STUFF WKLD CODE INTO FILE 60 61.2 62.07 ETC ;5/2/91 09:03
- ;;5.2T9;LR;**221,1018**;Nov 17, 2004
- 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
- LRCAPF ;DALISC/FHS-STUFF WKLD CODE INTO FILE 60 61.2 62.07 ETC ;5/2/91 09:03
- +1 ;;5.2T9;LR;**221,1018**;Nov 17, 2004
- 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
