LRMIEDIM ;BPFO/DTG - LAB MICRO - LOOP ETIOLOGY FIELD FILE 61.2 FOR INACTIVE DATE ;08/15/2017
;;5.2;LAB SERVICE;**495**;Sep 27, 1994;Build 6
;
;associated to the [LRMI EDIT INACT DT MULTI 61.2] option
;
;This routine will go through the 61.2 by IDENTIFIER oldest to newest for those entries
;that do not have an INACTIVE DATE. The last entry (if the file for that combination was
;not complete) will be stored for upto 6 months so that when re-starting for that identifier
;it will allow to restart with that item if it does not have a inactive date or the next newest
;if it does. The person will also have the choice to start over from the oldest entry.
;
Q
;
EN ; entry point from option
N DIR,DIRUT,DIC,A,B,LRXT,MSG,LRRUN,LR0,LRIDENT,LRIDNM,X,Y,DIE,DTOUT,DR,DA,LR6491
EN1 S U="^" I $G(DT)="" S DT=$$DT^XLFDT
S B=$$SITE^VASITE,B=$P(B,U,1),LRXT="LRENT-INACT"
;
D ASKFILE
I $D(DIRUT)!(Y="^") K MSG D G OUT
. S MSG(1)="Identifier Type Not Selected. Quitting"
. S MSG(2)=""
. D DISP
S LRIDENT=Y,LRIDNM=Y(0)
K DIR,DIRUT
;get ^XTMP for identifier
S LRRUN=0,A=$G(^XTMP(LRXT,0)),B=$G(^XTMP(LRXT,LRIDENT,0))
I +B>0 S LRRUN=+B
I A="" S $P(A,U,3)="Save of Etiology File 61.2 Identifiers for Inactive Date entry"
S $P(A,U,1)=$$FMADD^XLFDT(DT,60),$P(A,U,2)=DT
S ^XTMP(LRXT,0)=A,^XTMP(LRXT,LRIDENT,0)=LRRUN
I LRRUN=0 D XSET(LRIDENT,"") G LOOP
S A=$$GETVAL(LRRUN)
K DIR,DIRUT S DIR(0)="SO^C:CONTINUE WITH "_$E($P(A,U,1),1,45)_" ["_(+B)_"];S:START OVER"
S DIR("L",1)=" CONTINUE WITH "_$E($P(A,U,1),1,45)_" ["_(+B)_"] (C)"
S DIR("L")=" START OVER (S)"
D ^DIR
I $D(DIRUT)!(Y="^") K MSG D G OUT
. S MSG(1)="Continuation Method Not Selected. Quitting"
. S MSG(2)=""
. D DISP
I $G(Y)="S" S LRRUN=0 G LOOP
S LRRUN=LRRUN+1
;
LOOP S LRRUN=$O(^LAB(61.2,LRRUN)) I 'LRRUN D XSET(LRIDENT,"") D G OUT
. K MSG S MSG(1)="All Entries for the Selected Identifier ("_LRIDNM_") have been reviewed. Quitting"
. S MSG(2)=""
. D DISP
S LR0=$G(^LAB(61.2,LRRUN,0)),LR6491=$G(^LAB(61.2,LRRUN,"64.91"))
; check if inactive date
I $P(LR6491,U,2)'="" D XSET(LRIDENT,LRRUN) G LOOP
; check if right identifier
I LRIDENT="X" G LP1
I $P(LR0,U,5)=""&(LRIDENT="N") G LP1
I $P(LR0,U,5)'=LRIDENT D XSET(LRIDENT,LRRUN) G LOOP
;
LP1 ; ask inactive date
; first lock entry
L +^LAB(61.2,LRRUN):60 I '$T D G OUT
. K MSG S MSG(1)="Not Able to Lock Entry ("_$E($P(LR0,U,1),1,45)_" ["_LRRUN_"]). Quitting"
. S MSG(2)=""
. D DISP
W !!,"Organism: ",$E($P(LR0,U,1),1,45)," (",LRRUN,")"
K Y,DIE,DTOUT S DIE("NO^")="OUTOK",DIE="^LAB(61.2,",DA=LRRUN,DR="64.9102" D ^DIE
L -^LAB(61.2,LRRUN)
; check if ^ was entered
I $D(Y) D G OUT
. K MSG S MSG(1)="An '^' was detected. Quitting"
. S MSG(2)=""
. D DISP
D XSET(LRIDENT,LRRUN)
G LOOP
;
ASKFILE() ; Ask user to select Identifier
K DIR,DIRUT
S DIR(0)="SO^B:BACTERIUM;F:FUNGUS;P:PARASITE;M:MYCOBACTERIUM;V:VIRUS;C:CHEMICAL;D:DRUG;R:RICKETTSIAE;A:PHYSICAL AGENT;N:NULL;X:ALL"
S DIR("L",1)=" BACTERIUM (B)"
S DIR("L",2)=" FUNGUS (F)"
S DIR("L",3)=" PARASITE (P)"
S DIR("L",4)=" MYCOBACTERIUM (M)"
S DIR("L",5)=" VIRUS (V)"
S DIR("L",6)=" CHEMICAL (C)"
S DIR("L",7)=" DRUG (D)"
S DIR("L",8)=" RICKETTSIAE (R)"
S DIR("L",9)=" PHYSICAL AGENT (A)"
S DIR("L",10)=" NULL (N)"
S DIR("L")=" ALL (X)"
S DIR("A")="Enter the Identifier Name or Code "
D ^DIR
Q
;
DISP ; display message
D CLEAR^VALM1
D BMES^XPDUTL(.MSG)
Q
;
GETVAL(C) ; get 61.2 info
N A,B,D
S A=$G(^LAB(61.2,C,0)),B=$G(^LAB(61.2,C,64.91))
S D=$P(A,U,1)_U_$P(A,U,5)_U_$P(B,U,2)
Q D
;
OUT ; quit
K DIR,DIRUT,DIC,A,B,LRXT,MSG,LRRUN,LR0,LRIDENT,LRIDNM,X,Y,DIE,DTOUT,DR,DA,LR6491,DIE("NO^")
Q
;
XSET(A,B) ; set into XTMP
; A - Identifier, B - value
S ^XTMP(LRXT,A,0)=B
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRMIEDIM 3969 printed Apr 09, 2024@21:05:26 Page 2
LRMIEDIM ;BPFO/DTG - LAB MICRO - LOOP ETIOLOGY FIELD FILE 61.2 FOR INACTIVE DATE ;08/15/2017
+1 ;;5.2;LAB SERVICE;**495**;Sep 27, 1994;Build 6
+2 ;
+3 ;associated to the [LRMI EDIT INACT DT MULTI 61.2] option
+4 ;
+5 ;This routine will go through the 61.2 by IDENTIFIER oldest to newest for those entries
+6 ;that do not have an INACTIVE DATE. The last entry (if the file for that combination was
+7 ;not complete) will be stored for upto 6 months so that when re-starting for that identifier
+8 ;it will allow to restart with that item if it does not have a inactive date or the next newest
+9 ;if it does. The person will also have the choice to start over from the oldest entry.
+10 ;
+11 QUIT
+12 ;
EN ; entry point from option
+1 NEW DIR,DIRUT,DIC,A,B,LRXT,MSG,LRRUN,LR0,LRIDENT,LRIDNM,X,Y,DIE,DTOUT,DR,DA,LR6491
EN1 SET U="^"
IF $GET(DT)=""
SET DT=$$DT^XLFDT
+1 SET B=$$SITE^VASITE
SET B=$PIECE(B,U,1)
SET LRXT="LRENT-INACT"
+2 ;
+3 DO ASKFILE
+4 IF $DATA(DIRUT)!(Y="^")
KILL MSG
Begin DoDot:1
+5 SET MSG(1)="Identifier Type Not Selected. Quitting"
+6 SET MSG(2)=""
+7 DO DISP
End DoDot:1
GOTO OUT
+8 SET LRIDENT=Y
SET LRIDNM=Y(0)
+9 KILL DIR,DIRUT
+10 ;get ^XTMP for identifier
+11 SET LRRUN=0
SET A=$GET(^XTMP(LRXT,0))
SET B=$GET(^XTMP(LRXT,LRIDENT,0))
+12 IF +B>0
SET LRRUN=+B
+13 IF A=""
SET $PIECE(A,U,3)="Save of Etiology File 61.2 Identifiers for Inactive Date entry"
+14 SET $PIECE(A,U,1)=$$FMADD^XLFDT(DT,60)
SET $PIECE(A,U,2)=DT
+15 SET ^XTMP(LRXT,0)=A
SET ^XTMP(LRXT,LRIDENT,0)=LRRUN
+16 IF LRRUN=0
DO XSET(LRIDENT,"")
GOTO LOOP
+17 SET A=$$GETVAL(LRRUN)
+18 KILL DIR,DIRUT
SET DIR(0)="SO^C:CONTINUE WITH "_$EXTRACT($PIECE(A,U,1),1,45)_" ["_(+B)_"];S:START OVER"
+19 SET DIR("L",1)=" CONTINUE WITH "_$EXTRACT($PIECE(A,U,1),1,45)_" ["_(+B)_"] (C)"
+20 SET DIR("L")=" START OVER (S)"
+21 DO ^DIR
+22 IF $DATA(DIRUT)!(Y="^")
KILL MSG
Begin DoDot:1
+23 SET MSG(1)="Continuation Method Not Selected. Quitting"
+24 SET MSG(2)=""
+25 DO DISP
End DoDot:1
GOTO OUT
+26 IF $GET(Y)="S"
SET LRRUN=0
GOTO LOOP
+27 SET LRRUN=LRRUN+1
+28 ;
LOOP SET LRRUN=$ORDER(^LAB(61.2,LRRUN))
IF 'LRRUN
DO XSET(LRIDENT,"")
Begin DoDot:1
+1 KILL MSG
SET MSG(1)="All Entries for the Selected Identifier ("_LRIDNM_") have been reviewed. Quitting"
+2 SET MSG(2)=""
+3 DO DISP
End DoDot:1
GOTO OUT
+4 SET LR0=$GET(^LAB(61.2,LRRUN,0))
SET LR6491=$GET(^LAB(61.2,LRRUN,"64.91"))
+5 ; check if inactive date
+6 IF $PIECE(LR6491,U,2)'=""
DO XSET(LRIDENT,LRRUN)
GOTO LOOP
+7 ; check if right identifier
+8 IF LRIDENT="X"
GOTO LP1
+9 IF $PIECE(LR0,U,5)=""&(LRIDENT="N")
GOTO LP1
+10 IF $PIECE(LR0,U,5)'=LRIDENT
DO XSET(LRIDENT,LRRUN)
GOTO LOOP
+11 ;
LP1 ; ask inactive date
+1 ; first lock entry
+2 LOCK +^LAB(61.2,LRRUN):60
IF '$TEST
Begin DoDot:1
+3 KILL MSG
SET MSG(1)="Not Able to Lock Entry ("_$EXTRACT($PIECE(LR0,U,1),1,45)_" ["_LRRUN_"]). Quitting"
+4 SET MSG(2)=""
+5 DO DISP
End DoDot:1
GOTO OUT
+6 WRITE !!,"Organism: ",$EXTRACT($PIECE(LR0,U,1),1,45)," (",LRRUN,")"
+7 KILL Y,DIE,DTOUT
SET DIE("NO^")="OUTOK"
SET DIE="^LAB(61.2,"
SET DA=LRRUN
SET DR="64.9102"
DO ^DIE
+8 LOCK -^LAB(61.2,LRRUN)
+9 ; check if ^ was entered
+10 IF $DATA(Y)
Begin DoDot:1
+11 KILL MSG
SET MSG(1)="An '^' was detected. Quitting"
+12 SET MSG(2)=""
+13 DO DISP
End DoDot:1
GOTO OUT
+14 DO XSET(LRIDENT,LRRUN)
+15 GOTO LOOP
+16 ;
ASKFILE() ; Ask user to select Identifier
+1 KILL DIR,DIRUT
+2 SET DIR(0)="SO^B:BACTERIUM;F:FUNGUS;P:PARASITE;M:MYCOBACTERIUM;V:VIRUS;C:CHEMICAL;D:DRUG;R:RICKETTSIAE;A:PHYSICAL AGENT;N:NULL;X:ALL"
+3 SET DIR("L",1)=" BACTERIUM (B)"
+4 SET DIR("L",2)=" FUNGUS (F)"
+5 SET DIR("L",3)=" PARASITE (P)"
+6 SET DIR("L",4)=" MYCOBACTERIUM (M)"
+7 SET DIR("L",5)=" VIRUS (V)"
+8 SET DIR("L",6)=" CHEMICAL (C)"
+9 SET DIR("L",7)=" DRUG (D)"
+10 SET DIR("L",8)=" RICKETTSIAE (R)"
+11 SET DIR("L",9)=" PHYSICAL AGENT (A)"
+12 SET DIR("L",10)=" NULL (N)"
+13 SET DIR("L")=" ALL (X)"
+14 SET DIR("A")="Enter the Identifier Name or Code "
+15 DO ^DIR
+16 QUIT
+17 ;
DISP ; display message
+1 DO CLEAR^VALM1
+2 DO BMES^XPDUTL(.MSG)
+3 QUIT
+4 ;
GETVAL(C) ; get 61.2 info
+1 NEW A,B,D
+2 SET A=$GET(^LAB(61.2,C,0))
SET B=$GET(^LAB(61.2,C,64.91))
+3 SET D=$PIECE(A,U,1)_U_$PIECE(A,U,5)_U_$PIECE(B,U,2)
+4 QUIT D
+5 ;
OUT ; quit
+1 KILL DIR,DIRUT,DIC,A,B,LRXT,MSG,LRRUN,LR0,LRIDENT,LRIDNM,X,Y,DIE,DTOUT,DR,DA,LR6491,DIE("NO^")
+2 QUIT
+3 ;
XSET(A,B) ; set into XTMP
+1 ; A - Identifier, B - value
+2 SET ^XTMP(LRXT,A,0)=B
+3 QUIT
