LRMISTF1 ;DALOI/STAFF - MASS DATA ENTRY INTO FILE 63.05 ; 7/9/16 10:57pm
;;5.2;LAB SERVICE;**121,128,202,263,264,295,350,427,473**;Sep 27, 1994;Build 1
;
; from LRMISTF
;
ASK ;
N LRAUTO,LRDUZ,LRIEN,LRPLREF
;
F D GET Q:LREND=99 D:'LREND ACC S:LREND LREND=0 D MORE Q:LREND K LRAUTO
Q
;
;
GET ;
N DIR,DIRUT,DTOUT,DUOUT,LRSTUFF,X,Y
;
S X1="",LREND=0
I LRMODE<3 D
. F R !,"What do you want entered?: ",X1:DTIME Q:'$T!(X1[U)!(X1="") D I $L(X1),$E(X1)'="?" S LREND=0 Q
. . I $S(X1[":":1,X1[";":1,1:0) S X1="?" D INFO Q
. . S X=X1 S:X[";" X="?" D @$S($G(H9)=11.57:"PN^LRNUM",$G(H9)=24:"AFS^LRNUM",1:"^LRMIXPD") S:'$D(X) X1="?" Q:X1'="?" D INFO
I X1[U S LREND=99 Q
;
S:LRMODE<3 LRSTUFF=X1
W !,"I will ",$S(LRMODE=1:"automatically stuff ",1:"prompt "),LRMF W:$D(LRSTUFF) !,"with ",LRSTUFF
F W !," ...OK" S %=1 D YN^DICN Q:% W !,"Answer 'Y'es or 'N'o"
I %'=1 S LREND=1 Q
;
I LRPF="P" S DR="S:$S($D(^LR(LRDFN,""MI"",LRIDT,"_LRSB_")):$P(^("_LRSB_"),U,2),1:"""")=""F"" Y="_$S(LRSB=1:11.55,LRSB=5:15.5,LRSB=8:19.5,LRSB=11:25.5,LRSB=16:35)_";"
I LRPF="F" S DR=""
S DR=DR_$S(LRSB=1:"11.5///"_LRPF_";11.55",LRSB=5:"15///"_LRPF_";15.5",LRSB=8:"19///"_LRPF_";19.5",LRSB=11:"23///"_LRPF_";25.5",1:"34///"_LRPF_";35")
S DR=DR_"////"_DUZ_";"_H9_$S(LRMODE=1:"///"_LRSTUFF,LRMODE=2:"//"_LRSTUFF,1:"")
;
K DIR
S DIR(0)="YO",DIR("A")="Verify all work automatically",DIR("B")="Yes"
D ^DIR
I $D(DIRUT) S LREND=1 Q
I Y=1 S DR=DR_";"_$S(LRSB=1:11,LRSB=5:14,LRSB=8:18,LRSB=11:22,1:33)_"///NOW",LRAUTO=""
;
;
K DIR
S DIR(0)="YO",DIR("A")="Designate the individual test as complete",DIR("B")="No"
D ^DIR
I $D(DIRUT) S LREND=1 Q
S LRCO=+Y
;
;
; Ask for performing lab if automatically verifying.
; Setup array of fields to performing lab reference
K LRDUZ,LRPLREF
;
S LRPLREF(11.57)="1:6"
S LRPLREF(11.58)="1;5"
S LRPLREF(11.6)="2,0"
S LRPLREF(13)="4,0"
S LRPLREF(15.51)="24,0"
S LRPLREF(17)="7,0"
S LRPLREF(19.6)="15,0"
S LRPLREF(21)="10,0"
S LRPLREF(24)="11;3"
S LRPLREF(27)="13,0"
S LRPLREF(37)="18,0"
;
I $D(LRAUTO) D
. N DIR,DIRUT,DTOUT,DUOUT,LRDPL,X,Y
. S LRDPL=$$GET^XPAR("USR","LR VER DEFAULT PERFORMING LAB",1,"Q")
. I LRDPL<1 S LRDPL=DUZ(2)
. ;
. I '($$GET^XPAR("ALL","LR ASK PERFORMING LAB MICRO",1,"Q")) D Q
. . I LRDPL'=DUZ(2) S LRDUZ(2)=LRDPL
. . S $P(LRPLREF(H9),"^")="0"
. ;
. S X=$$SELPL^LRVERA(LRDPL)
. I X<1 S LREND=1 Q
. I X'=DUZ(2) S LRDUZ(2)=X
. S DIR(0)="S^1:Entire report;2:"_LRMF_" section of report"
. S DIR("A")="Designate performing laboratory for"
. S DIR("?")="Enter a code from the list or '^' to exit."
. D ^DIR
. I $D(DIRUT) S LREND=1 Q
. I Y=1 S $P(LRPLREF(H9),"^")="0"
Q
;
;
INFO ;
W !,$$CJ^XLFSTR("What you enter will go through the input transform to be stored in the.",IOM)
W !,$$CJ^XLFSTR("Result field of the test",IOM)
W !,$$CJ^XLFSTR("The punctuations of ';' or ':' are not allowed in Batch Data Entry.",IOM),!
Q
;
;
ACC ;
N DIC,DIR,DIRUT,DTOUT,DUOUT
W !,"Enter the accessions you wish to edit." D LRAN^LRMIUT
I +$O(LRAN(0))>0 W !,"Editing the following:" S (J,LRAN)=0 F S LRAN=+$O(LRAN(LRAN)) Q:LRAN<1 W !,LRAN S J=J+1 I J#(IOSL-2)=0 R !,"Press return to continue or '^' to escape ",X:DTIME I X[U S LREND=1 Q
Q:LREND
;
S DIR(0)="YO",DIR("A")="Everything OK",DIR("B")="NO"
D ^DIR
I Y<1 Q
;
S LRAN=0
F S LRAN=+$O(LRAN(LRAN)) Q:LRAN<1 D STUFF Q:LREND
Q
;
;
STUFF ;
N LREND
;
I '$D(^LRO(68,LRAA,1,LRAD,1,LRAN,0))!'$D(^(3)) W !,"Acc: ",LRAN," not set up." Q
I $P(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U,4) W !,"Acc: ",LRAN," has been previously verified by a microbiology supervisor." Q
;
S LRNOP=1,J=0 F S J=+$O(^LRO(68,LRAA,1,LRAD,1,LRAN,4,J)) Q:J<1 I LRTEST=+^(J,0) S LRNOP=$P(^(0),U,5) Q
I LRNOP=1 W !,"Acc: ",LRAN," doesn't have the test required." Q
I LRNOP>1 W !,"Acc: ",LRAN," has been completed for the selected test." Q
;
I H9=11.57!(H9=11.58) S LROK=0 D @$S(H9=11.57:"UR",1:"SPUT") I 'LROK W !,"Acc: ",LRAN," doesn't have the specimen required." Q
;
W !,"Acc: ",LRAN
S LRDFN=+^LRO(68,LRAA,1,LRAD,1,LRAN,0),LRLLOC=$P(^(0),U,7),LRODT=$S($P(^(0),U,4):$P(^(0),U,4),1:$P(^(0),U,3)),LRSN=$P(^(0),U,5)
S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3)
D PT^LRX
W ?15,PNM,?45,SSN,?65,LRWRD,!
;
S LRCDT=+^LRO(68,LRAA,1,LRAD,1,LRAN,3),LRIDT=+$P(^(3),U,5),DIE="^LR("_LRDFN_",""MI"",",DA=LRIDT,DA(1)=LRDFN
D ^DIE,UPDATE^LRPXRM(LRDFN,"MI",LRIDT)
I $D(Y) S LREND=1 Q
;
I LRCO D
. S X=$P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTEST,0),U,5)
. I X K ^LRO(68,LRAA,1,LRAD,1,"AD",$P(X,"."),LRAN),^LRO(68,LRAA,1,LRAD,1,"AC",X,LRAN)
. S $P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTEST,0),U,4)=DUZ,$P(^(0),U,8)=$G(LRCDEF)
. S Y=$$NOW^XLFDT
. S $P(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTEST,0),U,5)=Y
. S ^LRO(68,LRAA,1,LRAD,1,"AD",$P(Y,"."),LRAN)="",^LRO(68,LRAA,1,LRAD,1,"AC",Y,LRAN)=""
. N CORRECT S:$G(LRCORECT) CORRECT=1 D NEW^LR7OB1(LRODT,LRSN,"RE")
;
I $D(LRAUTO) D PL,STF^LRMIUT,LEDI^LRVR0
;
Q
;
;
MORE ;
S LREND=1
F W !,"Do you wish to make a new entry for the ",LRMF," field" S %=2 D YN^DICN Q:% W !,"Answer 'Y'es or 'N'o"
I %=1 S LREND=0
Q
;
;
UR ;
S J=0
F S J=+$O(^LRO(68,LRAA,1,LRAD,1,LRAN,5,J)) Q:J<1 I LRURINE=+^(J,0) S LROK=1 Q
Q
;
;
SPUT ;
S J=0
F S J=+$O(^LRO(68,LRAA,1,LRAD,1,LRAN,5,J)) Q:J<1 I 360=+^(J,0) S LROK=1 Q
Q
;
;
PL ; Store performing lab on automatic verification
;
N LRPL,LRREF,LRX,LRY
;
S LRY=$G(LRPLREF(H9))
I LRY="" Q
S LRREF=LRDFN_",MI,"_LRIDT_","_LRY
S LRPL=$S($G(LRDUZ(2)):LRDUZ(2),1:DUZ(2))
;
S LRX=$O(^LR(LRDFN,"PL","B",LRREF,0))
I 'LRX D CNE^LRRPLU(LRDFN,LRREF,LRPL) Q
I $P(^LR(LRDFN,"PL",LRX,0),"^",2)'=LRPL D UEE^LRRPLU(LRDFN,LRREF,LRPL)
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRMISTF1 5802 printed Oct 16, 2024@18:18:12 Page 2
LRMISTF1 ;DALOI/STAFF - MASS DATA ENTRY INTO FILE 63.05 ; 7/9/16 10:57pm
+1 ;;5.2;LAB SERVICE;**121,128,202,263,264,295,350,427,473**;Sep 27, 1994;Build 1
+2 ;
+3 ; from LRMISTF
+4 ;
ASK ;
+1 NEW LRAUTO,LRDUZ,LRIEN,LRPLREF
+2 ;
+3 FOR
DO GET
if LREND=99
QUIT
if 'LREND
DO ACC
if LREND
SET LREND=0
DO MORE
if LREND
QUIT
KILL LRAUTO
+4 QUIT
+5 ;
+6 ;
GET ;
+1 NEW DIR,DIRUT,DTOUT,DUOUT,LRSTUFF,X,Y
+2 ;
+3 SET X1=""
SET LREND=0
+4 IF LRMODE<3
Begin DoDot:1
+5 FOR
READ !,"What do you want entered?: ",X1:DTIME
if '$TEST!(X1[U)!(X1="")
QUIT
Begin DoDot:2
+6 IF $SELECT(X1[":":1,X1[";":1,1:0)
SET X1="?"
DO INFO
QUIT
+7 SET X=X1
if X[";"
SET X="?"
DO @$SELECT($GET(H9)=11.57:"PN^LRNUM",$GET(H9)=24:"AFS^LRNUM",1:"^LRMIXPD")
if '$DATA(X)
SET X1="?"
if X1'="?"
QUIT
DO INFO
End DoDot:2
IF $LENGTH(X1)
IF $EXTRACT(X1)'="?"
SET LREND=0
QUIT
End DoDot:1
+8 IF X1[U
SET LREND=99
QUIT
+9 ;
+10 if LRMODE<3
SET LRSTUFF=X1
+11 WRITE !,"I will ",$SELECT(LRMODE=1:"automatically stuff ",1:"prompt "),LRMF
if $DATA(LRSTUFF)
WRITE !,"with ",LRSTUFF
+12 FOR
WRITE !," ...OK"
SET %=1
DO YN^DICN
if %
QUIT
WRITE !,"Answer 'Y'es or 'N'o"
+13 IF %'=1
SET LREND=1
QUIT
+14 ;
+15 IF LRPF="P"
SET DR="S:$S($D(^LR(LRDFN,""MI"",LRIDT,"_LRSB_")):$P(^("_LRSB_"),U,2),1:"""")=""F"" Y="_$SELECT(LRSB=1:11.55,LRSB=5:15.5,LRSB=8:19.5,LRSB=11:25.5,LRSB=16:35)_";"
+16 IF LRPF="F"
SET DR=""
+17 SET DR=DR_$SELECT(LRSB=1:"11.5///"_LRPF_";11.55",LRSB=5:"15///"_LRPF_";15.5",LRSB=8:"19///"_LRPF_";19.5",LRSB=11:"23///"_LRPF_";25.5",1:"34///"_LRPF_";35")
+18 SET DR=DR_"////"_DUZ_";"_H9_$SELECT(LRMODE=1:"///"_LRSTUFF,LRMODE=2:"//"_LRSTUFF,1:"")
+19 ;
+20 KILL DIR
+21 SET DIR(0)="YO"
SET DIR("A")="Verify all work automatically"
SET DIR("B")="Yes"
+22 DO ^DIR
+23 IF $DATA(DIRUT)
SET LREND=1
QUIT
+24 IF Y=1
SET DR=DR_";"_$SELECT(LRSB=1:11,LRSB=5:14,LRSB=8:18,LRSB=11:22,1:33)_"///NOW"
SET LRAUTO=""
+25 ;
+26 ;
+27 KILL DIR
+28 SET DIR(0)="YO"
SET DIR("A")="Designate the individual test as complete"
SET DIR("B")="No"
+29 DO ^DIR
+30 IF $DATA(DIRUT)
SET LREND=1
QUIT
+31 SET LRCO=+Y
+32 ;
+33 ;
+34 ; Ask for performing lab if automatically verifying.
+35 ; Setup array of fields to performing lab reference
+36 KILL LRDUZ,LRPLREF
+37 ;
+38 SET LRPLREF(11.57)="1:6"
+39 SET LRPLREF(11.58)="1;5"
+40 SET LRPLREF(11.6)="2,0"
+41 SET LRPLREF(13)="4,0"
+42 SET LRPLREF(15.51)="24,0"
+43 SET LRPLREF(17)="7,0"
+44 SET LRPLREF(19.6)="15,0"
+45 SET LRPLREF(21)="10,0"
+46 SET LRPLREF(24)="11;3"
+47 SET LRPLREF(27)="13,0"
+48 SET LRPLREF(37)="18,0"
+49 ;
+50 IF $DATA(LRAUTO)
Begin DoDot:1
+51 NEW DIR,DIRUT,DTOUT,DUOUT,LRDPL,X,Y
+52 SET LRDPL=$$GET^XPAR("USR","LR VER DEFAULT PERFORMING LAB",1,"Q")
+53 IF LRDPL<1
SET LRDPL=DUZ(2)
+54 ;
+55 IF '($$GET^XPAR("ALL","LR ASK PERFORMING LAB MICRO",1,"Q"))
Begin DoDot:2
+56 IF LRDPL'=DUZ(2)
SET LRDUZ(2)=LRDPL
+57 SET $PIECE(LRPLREF(H9),"^")="0"
End DoDot:2
QUIT
+58 ;
+59 SET X=$$SELPL^LRVERA(LRDPL)
+60 IF X<1
SET LREND=1
QUIT
+61 IF X'=DUZ(2)
SET LRDUZ(2)=X
+62 SET DIR(0)="S^1:Entire report;2:"_LRMF_" section of report"
+63 SET DIR("A")="Designate performing laboratory for"
+64 SET DIR("?")="Enter a code from the list or '^' to exit."
+65 DO ^DIR
+66 IF $DATA(DIRUT)
SET LREND=1
QUIT
+67 IF Y=1
SET $PIECE(LRPLREF(H9),"^")="0"
End DoDot:1
+68 QUIT
+69 ;
+70 ;
INFO ;
+1 WRITE !,$$CJ^XLFSTR("What you enter will go through the input transform to be stored in the.",IOM)
+2 WRITE !,$$CJ^XLFSTR("Result field of the test",IOM)
+3 WRITE !,$$CJ^XLFSTR("The punctuations of ';' or ':' are not allowed in Batch Data Entry.",IOM),!
+4 QUIT
+5 ;
+6 ;
ACC ;
+1 NEW DIC,DIR,DIRUT,DTOUT,DUOUT
+2 WRITE !,"Enter the accessions you wish to edit."
DO LRAN^LRMIUT
+3 IF +$ORDER(LRAN(0))>0
WRITE !,"Editing the following:"
SET (J,LRAN)=0
FOR
SET LRAN=+$ORDER(LRAN(LRAN))
if LRAN<1
QUIT
WRITE !,LRAN
SET J=J+1
IF J#(IOSL-2)=0
READ !,"Press return to continue or '^' to escape ",X:DTIME
IF X[U
SET LREND=1
QUIT
+4 if LREND
QUIT
+5 ;
+6 SET DIR(0)="YO"
SET DIR("A")="Everything OK"
SET DIR("B")="NO"
+7 DO ^DIR
+8 IF Y<1
QUIT
+9 ;
+10 SET LRAN=0
+11 FOR
SET LRAN=+$ORDER(LRAN(LRAN))
if LRAN<1
QUIT
DO STUFF
if LREND
QUIT
+12 QUIT
+13 ;
+14 ;
STUFF ;
+1 NEW LREND
+2 ;
+3 IF '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))!'$DATA(^(3))
WRITE !,"Acc: ",LRAN," not set up."
QUIT
+4 IF $PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,3),U,4)
WRITE !,"Acc: ",LRAN," has been previously verified by a microbiology supervisor."
QUIT
+5 ;
+6 SET LRNOP=1
SET J=0
FOR
SET J=+$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,4,J))
if J<1
QUIT
IF LRTEST=+^(J,0)
SET LRNOP=$PIECE(^(0),U,5)
QUIT
+7 IF LRNOP=1
WRITE !,"Acc: ",LRAN," doesn't have the test required."
QUIT
+8 IF LRNOP>1
WRITE !,"Acc: ",LRAN," has been completed for the selected test."
QUIT
+9 ;
+10 IF H9=11.57!(H9=11.58)
SET LROK=0
DO @$SELECT(H9=11.57:"UR",1:"SPUT")
IF 'LROK
WRITE !,"Acc: ",LRAN," doesn't have the specimen required."
QUIT
+11 ;
+12 WRITE !,"Acc: ",LRAN
+13 SET LRDFN=+^LRO(68,LRAA,1,LRAD,1,LRAN,0)
SET LRLLOC=$PIECE(^(0),U,7)
SET LRODT=$SELECT($PIECE(^(0),U,4):$PIECE(^(0),U,4),1:$PIECE(^(0),U,3))
SET LRSN=$PIECE(^(0),U,5)
+14 SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)
SET DFN=$PIECE(^(0),U,3)
+15 DO PT^LRX
+16 WRITE ?15,PNM,?45,SSN,?65,LRWRD,!
+17 ;
+18 SET LRCDT=+^LRO(68,LRAA,1,LRAD,1,LRAN,3)
SET LRIDT=+$PIECE(^(3),U,5)
SET DIE="^LR("_LRDFN_",""MI"","
SET DA=LRIDT
SET DA(1)=LRDFN
+19 DO ^DIE
DO UPDATE^LRPXRM(LRDFN,"MI",LRIDT)
+20 IF $DATA(Y)
SET LREND=1
QUIT
+21 ;
+22 IF LRCO
Begin DoDot:1
+23 SET X=$PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTEST,0),U,5)
+24 IF X
KILL ^LRO(68,LRAA,1,LRAD,1,"AD",$PIECE(X,"."),LRAN),^LRO(68,LRAA,1,LRAD,1,"AC",X,LRAN)
+25 SET $PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTEST,0),U,4)=DUZ
SET $PIECE(^(0),U,8)=$GET(LRCDEF)
+26 SET Y=$$NOW^XLFDT
+27 SET $PIECE(^LRO(68,LRAA,1,LRAD,1,LRAN,4,LRTEST,0),U,5)=Y
+28 SET ^LRO(68,LRAA,1,LRAD,1,"AD",$PIECE(Y,"."),LRAN)=""
SET ^LRO(68,LRAA,1,LRAD,1,"AC",Y,LRAN)=""
+29 NEW CORRECT
if $GET(LRCORECT)
SET CORRECT=1
DO NEW^LR7OB1(LRODT,LRSN,"RE")
End DoDot:1
+30 ;
+31 IF $DATA(LRAUTO)
DO PL
DO STF^LRMIUT
DO LEDI^LRVR0
+32 ;
+33 QUIT
+34 ;
+35 ;
MORE ;
+1 SET LREND=1
+2 FOR
WRITE !,"Do you wish to make a new entry for the ",LRMF," field"
SET %=2
DO YN^DICN
if %
QUIT
WRITE !,"Answer 'Y'es or 'N'o"
+3 IF %=1
SET LREND=0
+4 QUIT
+5 ;
+6 ;
UR ;
+1 SET J=0
+2 FOR
SET J=+$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,5,J))
if J<1
QUIT
IF LRURINE=+^(J,0)
SET LROK=1
QUIT
+3 QUIT
+4 ;
+5 ;
SPUT ;
+1 SET J=0
+2 FOR
SET J=+$ORDER(^LRO(68,LRAA,1,LRAD,1,LRAN,5,J))
if J<1
QUIT
IF 360=+^(J,0)
SET LROK=1
QUIT
+3 QUIT
+4 ;
+5 ;
PL ; Store performing lab on automatic verification
+1 ;
+2 NEW LRPL,LRREF,LRX,LRY
+3 ;
+4 SET LRY=$GET(LRPLREF(H9))
+5 IF LRY=""
QUIT
+6 SET LRREF=LRDFN_",MI,"_LRIDT_","_LRY
+7 SET LRPL=$SELECT($GET(LRDUZ(2)):LRDUZ(2),1:DUZ(2))
+8 ;
+9 SET LRX=$ORDER(^LR(LRDFN,"PL","B",LRREF,0))
+10 IF 'LRX
DO CNE^LRRPLU(LRDFN,LRREF,LRPL)
QUIT
+11 IF $PIECE(^LR(LRDFN,"PL",LRX,0),"^",2)'=LRPL
DO UEE^LRRPLU(LRDFN,LRREF,LRPL)
+12 ;
+13 QUIT
