LRARCHIV ; IHS/DIR/AAB - FIRST ROUTINE FOR PATIENT ARCHIVE 12/12/96 10:16 ;
;;5.2T9;LR;**1002,1018**;Nov 17, 2004
;;5.2;LAB SERVICE;**59,111**;Sep 27, 1994
;
; Taken from--> SET UP O("S") VARIABLES FOR ARCHIVE. ;2/5/91 12:30 ;
INIT ;
;
;
;
K ^TMP("LRBAD"),^TMP("LRUNV"),^TMP("LRNOD")
;
SEARCH ;
S OK=1
; Rewrite of basic archive SEARCH function for ^LR data
;
;--> Following the F1 variable tells you where you are
;
;^LAB(69.9,1,6,1,0) = ARCH-1^VAMC^2970318.0941^1^2970318
;
;--> F1=1 or 2 or 3 or 4or 5 depending what step has been done
;
;DATA TYPE: Set of Codes |
; 1:Searching------------------|
; 2:Search done----------------|
; 3:Clear----------------------|
; 4:Purging--------------------|
; 5:Purge done-----------------|
;SERCHING:
; Looks through the entire LR global by patient (LRDFN) for all
; eligible entries by date.
; New functionality also make certain all associated eligiable data is
; forced to a perminant cume page.
;
I '$G(F1) G MEET QUIT
S OK=1 D RESTART^LRAR06:$G(F1)=1
I 'OK D END QUIT
;
I $G(F1)>1 W !,"Please finish the Clear and Purge steps first." D QUIT Q
;
I $G(F1)=0 S:'$D(^LAB(69.9,1,6,0)) ^LAB(69.9,1,6,0)="^69.9003A^^" D TAPE^LRAR06
;
I $G(DA)<1!($G(P1)<1) D QUIT Q
PAT ;
; Entry for testing--------------------->
STEPOUT ;
MEET ;
W @IOF,!!,"Welcome to The Search Option for the New Archive Modual",!
;
I '$G(P1) S OK=1 D TAPE^LRAR06 I 'OK D END QUIT
;E W !,"A file entry IS NOT present"
;
; Make a list of data or not
;
;
W !,"Shall I prepare a list of patients that will have data archived"
S %=2 D YN^DICN
;
QUES I %=0 W !,"Answering YES to this question will produce" D G PAT
. W "a list of patients that will have data archived."
;
S LRPAT=0 S:%=1 LRPAT=1
T ;
I '$G(P1) W !,"Tape name not defined. Please start again."
I QUIT
;
S ^LAB(69.9,1,"TAPE")=P1
S $P(^LAB(69.9,1,6,P1,0),U,4)=1 ;---SEARCH IS IN PROGRESS
S X=1
S LRP1=P1
D LRSUB1 D DEVICE
QUIT
END ;
D QUIT
Q
;
DEVICE ;
S %ZIS="Q"
QUE ;
S ZTSAVE("LR*")="",ZTRTN="LR^LRAR04",ZTDESC="Archive search option."
S ZTSAVE("LR*")=""
S ZTSAVE("^TMP(""LR9""")=""
D IO^LRWU
QUIT
DQ1 ;
;
K OK,LRI
U IO
S LRC1=1,LRC2=0,LRC3=0,Y=LR(1)
D DD^LRX
W @IOF,!,"LAB DATA ARCHIVE for data before ",Y
W ". on " D STAMP^LRX S X=1 X ^%ZOSF("PRIORITY")
I '$G(LREDT3) D TIME^LRAR06
S X2=LREDT3,X1=LR(1) D ^%DTC
W !!,"Number of Days To be searched: ",X
QUIT
;
; Get test data names from 63.04
;
LRSUB1 S LRSUB=1
F S LRSUB=$O(^DD(63.04,LRSUB)) Q:LRSUB<1 D
. I $D(^DD(63.04,LRSUB,0)),'$D(^DD(63.999904,LRSUB)) D
.. S LRX0=^DD(63.04,LRSUB,0) S LRX3=$S($D(^(3)):^(3),1:"")
.. S ^DD(63.999904,LRSUB,0)=LRX0 S:LRX3'="" ^(3)=LRX3
.. S ^DD(63.999904,"B",$P(LRX0,U),LRSUB)=""
K X,Y,L1,L2
;
;D ^AAHAGL
;
;QUIT ;****************************************************
;
;
;
PROCESS ;
;
;
K ^LAR("DHZ")
;
K ^TMP("LRT2")
;
D SET^LRAR03
;
;
;S $P(^LAB(69.9,1,6,P1,0),U,4)=2 L -^LAR
QUIT
LST ;
W @IOF
S OK=1
U IO
S LRPAGE=1
D HEAD
I $G(LRPAT) W !! S PNM="" F S PNM=$O(^LAR("NAME",PNM)) Q:PNM="" D
. S LRDFN=0
. F S LRDFN=$O(^LAR("NAME",PNM,LRDFN)) Q:+LRDFN'>0!('OK) D
.. I $D(^LR(LRDFN,0))#2 N PNM S LRDPF=$P(^LR(LRDFN,0),"^",2) D
... Q:'OK
... S DFN=$P(^LR(LRDFN,0),"^",3)
... D CHKPG Q:'OK D DEM^LRX W !,PNM,?30,SSN
.. I '$D(^LR(LRDFN,0))#2 D
... W !!,PNM," LRDFN # "_LRDFN_" Has Been Deleted from ^LR( ",!,$C(7),"SSN = Unknown",!
;
LISTS ;
;
I 'OK S OK=1 G AROUND
I IOST'["C-" G AROUND
S OK=1
I IOST["C-" S DIR(0)="E" D ^DIR
AROUND F LRQ="^TMP(""LRBAD"")","^TMP(""LRUNV"")","^TMP(""LRNOD"")" Q:LRQ="" D
. W @IOF
. W !,$$CJ^XLFSTR($S(LRQ["LRBAD":"Entries with bad Data",LRQ["LRUNV":"Entries that were not verified",1:"Entries with no data"),IOM),!!
. F S LRQ=$Q(@LRQ) Q:LRQ'["LR" D CHKPG Q:'OK W !,@LRQ
QUIT ;
;D KILL^LRAR01 D KVAR^VADPT K F1,LRC1,LRC2,LRC3 U IO(0)
;D KILL^LRAR01 D KVAR^BLRDPT K F1,LRC1,LRC2,LRC3 U IO(0) ;IHS/OIRM TUC/AAB 10/24/97
;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
D KILL^LRAR01 D @$S($$ISPIMS^BLRUTIL:"KVAR^VADPT",1:"KVAR^BLRDPT") K F1,LRC1,LRC2,LRC3 U IO(0) ;IHS/OIRM TUC/AAB 10/24/97
;----- END IHS MODIFICATIONS
;
;
I $G(LRP1) S $P(^LAB(69.9,1,6,LRP1,0),U,4)=2 ;----SEARCH IS DONE
;
K ^TMP("LRBAD"),^TMP("LRUNV"),^TMP("LRNOD")
QUIT
CHKPG ;
Q:'OK
I IOSL-$Y'>3&($E(IOST,1,2)="C-") S DIR(0)="E" D ^DIR K DIR D
. W @IOF
. I $D(DTOUT)!($D(DUOUT)) S OK=0
Q:'OK
I IOSL-$Y'>3&($E(IOST,1,2)="P-") S LRPAGE=LRPAGE+1 D HEAD
;
QUIT
HEAD ;
W $$RJ^XLFSTR("Page "_LRPAGE,IOM),!
Q
CLEAN ;
D CLEAN^LRAR01
Q
PURGE ;
D PURGE^LRAR01
Q
LRARCHIV ; IHS/DIR/AAB - FIRST ROUTINE FOR PATIENT ARCHIVE 12/12/96 10:16 ;
+1 ;;5.2T9;LR;**1002,1018**;Nov 17, 2004
+2 ;;5.2;LAB SERVICE;**59,111**;Sep 27, 1994
+3 ;
+4 ; Taken from--> SET UP O("S") VARIABLES FOR ARCHIVE. ;2/5/91 12:30 ;
INIT ;
+1 ;
+2 ;
+3 ;
+4 KILL ^TMP("LRBAD"),^TMP("LRUNV"),^TMP("LRNOD")
+5 ;
SEARCH ;
+1 SET OK=1
+2 ; Rewrite of basic archive SEARCH function for ^LR data
+3 ;
+4 ;--> Following the F1 variable tells you where you are
+5 ;
+6 ;^LAB(69.9,1,6,1,0) = ARCH-1^VAMC^2970318.0941^1^2970318
+7 ;
+8 ;--> F1=1 or 2 or 3 or 4or 5 depending what step has been done
+9 ;
+10 ;DATA TYPE: Set of Codes |
+11 ; 1:Searching------------------|
+12 ; 2:Search done----------------|
+13 ; 3:Clear----------------------|
+14 ; 4:Purging--------------------|
+15 ; 5:Purge done-----------------|
+16 ;SERCHING:
+17 ; Looks through the entire LR global by patient (LRDFN) for all
+18 ; eligible entries by date.
+19 ; New functionality also make certain all associated eligiable data is
+20 ; forced to a perminant cume page.
+21 ;
+22 IF '$GET(F1)
GOTO MEET
QUIT
+23 SET OK=1
IF $GET(F1)=1
DO RESTART^LRAR06
+24 IF 'OK
DO END
QUIT
+25 ;
+26 IF $GET(F1)>1
WRITE !,"Please finish the Clear and Purge steps first."
DO QUIT
QUIT
+27 ;
+28 IF $GET(F1)=0
IF '$DATA(^LAB(69.9,1,6,0))
SET ^LAB(69.9,1,6,0)="^69.9003A^^"
DO TAPE^LRAR06
+29 ;
+30 IF $GET(DA)<1!($GET(P1)<1)
DO QUIT
QUIT
PAT ;
+1 ; Entry for testing--------------------->
STEPOUT ;
MEET ;
+1 WRITE @IOF,!!,"Welcome to The Search Option for the New Archive Modual",!
+2 ;
+3 IF '$GET(P1)
SET OK=1
DO TAPE^LRAR06
IF 'OK
DO END
QUIT
+4 ;E W !,"A file entry IS NOT present"
+5 ;
+6 ; Make a list of data or not
+7 ;
+8 ;
+9 WRITE !,"Shall I prepare a list of patients that will have data archived"
+10 SET %=2
DO YN^DICN
+11 ;
QUES IF %=0
WRITE !,"Answering YES to this question will produce"
Begin DoDot:1
+1 WRITE "a list of patients that will have data archived."
End DoDot:1
GOTO PAT
+2 ;
+3 SET LRPAT=0
IF %=1
SET LRPAT=1
T ;
+1 IF '$GET(P1)
WRITE !,"Tape name not defined. Please start again."
+2 IF $TEST
QUIT
+3 ;
+4 SET ^LAB(69.9,1,"TAPE")=P1
+5 ;---SEARCH IS IN PROGRESS
SET $PIECE(^LAB(69.9,1,6,P1,0),U,4)=1
+6 SET X=1
+7 SET LRP1=P1
+8 DO LRSUB1
DO DEVICE
+9 QUIT
END ;
+1 DO QUIT
+2 QUIT
+3 ;
DEVICE ;
+1 SET %ZIS="Q"
QUE ;
+1 SET ZTSAVE("LR*")=""
SET ZTRTN="LR^LRAR04"
SET ZTDESC="Archive search option."
+2 SET ZTSAVE("LR*")=""
+3 SET ZTSAVE("^TMP(""LR9""")=""
+4 DO IO^LRWU
+5 QUIT
DQ1 ;
+1 ;
+2 KILL OK,LRI
+3 USE IO
+4 SET LRC1=1
SET LRC2=0
SET LRC3=0
SET Y=LR(1)
+5 DO DD^LRX
+6 WRITE @IOF,!,"LAB DATA ARCHIVE for data before ",Y
+7 WRITE ". on "
DO STAMP^LRX
SET X=1
XECUTE ^%ZOSF("PRIORITY")
+8 IF '$GET(LREDT3)
DO TIME^LRAR06
+9 SET X2=LREDT3
SET X1=LR(1)
DO ^%DTC
+10 WRITE !!,"Number of Days To be searched: ",X
+11 QUIT
+12 ;
+13 ; Get test data names from 63.04
+14 ;
LRSUB1 SET LRSUB=1
+1 FOR
SET LRSUB=$ORDER(^DD(63.04,LRSUB))
IF LRSUB<1
QUIT
Begin DoDot:1
+2 IF $DATA(^DD(63.04,LRSUB,0))
IF '$DATA(^DD(63.999904,LRSUB))
Begin DoDot:2
+3 SET LRX0=^DD(63.04,LRSUB,0)
SET LRX3=$SELECT($DATA(^(3)):^(3),1:"")
+4 SET ^DD(63.999904,LRSUB,0)=LRX0
IF LRX3'=""
SET ^(3)=LRX3
+5 SET ^DD(63.999904,"B",$PIECE(LRX0,U),LRSUB)=""
End DoDot:2
End DoDot:1
+6 KILL X,Y,L1,L2
+7 ;
+8 ;D ^AAHAGL
+9 ;
+10 ;QUIT ;****************************************************
+11 ;
+12 ;
+13 ;
PROCESS ;
+1 ;
+2 ;
+3 KILL ^LAR("DHZ")
+4 ;
+5 KILL ^TMP("LRT2")
+6 ;
+7 DO SET^LRAR03
+8 ;
+9 ;
+10 ;S $P(^LAB(69.9,1,6,P1,0),U,4)=2 L -^LAR
+11 QUIT
LST ;
+1 WRITE @IOF
+2 SET OK=1
+3 USE IO
+4 SET LRPAGE=1
+5 DO HEAD
+6 IF $GET(LRPAT)
WRITE !!
SET PNM=""
FOR
SET PNM=$ORDER(^LAR("NAME",PNM))
IF PNM=""
QUIT
Begin DoDot:1
+7 SET LRDFN=0
+8 FOR
SET LRDFN=$ORDER(^LAR("NAME",PNM,LRDFN))
IF +LRDFN'>0!('OK)
QUIT
Begin DoDot:2
+9 IF $DATA(^LR(LRDFN,0))#2
NEW PNM
SET LRDPF=$PIECE(^LR(LRDFN,0),"^",2)
Begin DoDot:3
+10 IF 'OK
QUIT
+11 SET DFN=$PIECE(^LR(LRDFN,0),"^",3)
+12 DO CHKPG
IF 'OK
QUIT
DO DEM^LRX
WRITE !,PNM,?30,SSN
End DoDot:3
+13 IF '$DATA(^LR(LRDFN,0))#2
Begin DoDot:3
+14 WRITE !!,PNM," LRDFN # "_LRDFN_" Has Been Deleted from ^LR( ",!,$CHAR(7),"SSN = Unknown",!
End DoDot:3
End DoDot:2
End DoDot:1
+15 ;
LISTS ;
+1 ;
+2 IF 'OK
SET OK=1
GOTO AROUND
+3 IF IOST'["C-"
GOTO AROUND
+4 SET OK=1
+5 IF IOST["C-"
SET DIR(0)="E"
DO ^DIR
AROUND FOR LRQ="^TMP(""LRBAD"")","^TMP(""LRUNV"")","^TMP(""LRNOD"")"
IF LRQ=""
QUIT
Begin DoDot:1
+1 WRITE @IOF
+2 WRITE !,$$CJ^XLFSTR($SELECT(LRQ["LRBAD":"Entries with bad Data",LRQ["LRUNV":"Entries that were not verified",1:"Entries with no data"),IOM),!!
+3 FOR
SET LRQ=$QUERY(@LRQ)
IF LRQ'["LR"
QUIT
DO CHKPG
IF 'OK
QUIT
WRITE !,@LRQ
End DoDot:1
QUIT ;
+1 ;D KILL^LRAR01 D KVAR^VADPT K F1,LRC1,LRC2,LRC3 U IO(0)
+2 ;D KILL^LRAR01 D KVAR^BLRDPT K F1,LRC1,LRC2,LRC3 U IO(0) ;IHS/OIRM TUC/AAB 10/24/97
+3 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
+4 ;IHS/OIRM TUC/AAB 10/24/97
DO KILL^LRAR01
DO @$SELECT($$ISPIMS^BLRUTIL:"KVAR^VADPT",1:"KVAR^BLRDPT")
KILL F1,LRC1,LRC2,LRC3
USE IO(0)
+5 ;----- END IHS MODIFICATIONS
+6 ;
+7 ;
+8 ;----SEARCH IS DONE
IF $GET(LRP1)
SET $PIECE(^LAB(69.9,1,6,LRP1,0),U,4)=2
+9 ;
+10 KILL ^TMP("LRBAD"),^TMP("LRUNV"),^TMP("LRNOD")
+11 QUIT
CHKPG ;
+1 IF 'OK
QUIT
+2 IF IOSL-$Y'>3&($EXTRACT(IOST,1,2)="C-")
SET DIR(0)="E"
DO ^DIR
KILL DIR
Begin DoDot:1
+3 WRITE @IOF
+4 IF $DATA(DTOUT)!($DATA(DUOUT))
SET OK=0
End DoDot:1
+5 IF 'OK
QUIT
+6 IF IOSL-$Y'>3&($EXTRACT(IOST,1,2)="P-")
SET LRPAGE=LRPAGE+1
DO HEAD
+7 ;
+8 QUIT
HEAD ;
+1 WRITE $$RJ^XLFSTR("Page "_LRPAGE,IOM),!
+2 QUIT
CLEAN ;
+1 DO CLEAN^LRAR01
+2 QUIT
PURGE ;
+1 DO PURGE^LRAR01
+2 QUIT
