- LRAPQACN ;AVAMC/REG - CONSULTATION RPTS ;8/12/95 12:05 [ 04/28/2003 12:10 PM ]
- ;;5.2T9;LR;**1002,1008,1018**;Nov 17, 2004
- ;;5.2;LAB SERVICE;**72,242,252**;Sep 27, 1994
- W !!,"Consultation search with report.",!,"This report may take a while and should be queued to print at non-peak hours.",!,"OK to continue " S %=2 D YN^LRU G:%'=1 END
- D ^LRAP G:'$D(Y) END S LRN="065" F B=1:1 D ASK Q:X[U!(X="")!(X["ALL")
- G:B<2&(X="") END S:X=""&(B=2) LRN=$O(LRQ(0)) W !
- D B^LRU G:Y<0 END S LRSDT=LRSDT-.01,LRLDT=LRLDT+.99
- S ZTRTN="QUE^LRAPQACN" D BEG^LRUTL G:POP!($D(ZTSK)) END
- QUE U IO K ^TMP($J),^TMP("LRAP",$J) S S=LRSS,LR("DIWF")="W",LRO="",(LR,LR("A"),LR(1),LR(2),LR(3))=0 D L^LRU,S^LRU,XR^LRU,EN^LRUA
- S S(7)="PROCEDURE",LRSN=61.5,V=4,S(2)="ALL"
- S ^TMP($J,0)=S(2)_U_"FS"_U_LRO(68)_U_S(7)
- F X=0:0 S LRSDT=$O(^LR(LRXR,LRSDT)) Q:'LRSDT!(LRSDT>LRLDT) D @($S(LRSS="AU":"LRDFN^LRAUSM",1:"LRDFN^LRAPSM"))
- D ^LRAPSM1,EN2^LRUA,SET^LRUA,S^LRU S (LRS(5),LR("W"),LRQ(3),LRQ(9),LRA)=1
- ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
- Y2K S LRTMPA=$G(DT),LRTMPA=$S($E(LRTMPA,1)=2:200,1:300) ;IHS/DIR/FJE
- ;F A=0:0 S A=$O(^TMP($J,A)) Q:'A S X=A,%DT="" D ^%DT S LRY=$E(X,1,3) F B=0:0 S B=$O(^TMP($J,A,B)) Q:'B S ^TMP("LRAP",$J,LRY,B)=""
- F A=0:0 S A=$O(^TMP($J,A)) Q:'A S LRY=A+LRTMPA F B=0:0 S B=$O(^TMP($J,A,B)) Q:'B S ^TMP("LRAP",$J,LRY,B)="" ;IHS/DIR/FJE
- ;----- END IHS MODIFICATIONS
- I LRSS'="AU" D H S LRQ(3)=1,LR("F")=1
- F LRY=0:0 S LRY=$O(^TMP("LRAP",$J,LRY)) Q:'LRY!(LR("Q")) F LRAN=0:0 S LRAN=$O(^TMP("LRAP",$J,LRY,LRAN)) Q:'LRAN!(LR("Q")) S LRDFN=$O(^LR(LRXREF,LRY,LRABV,LRAN,0)) D @$S(LRSS'="AU":"B",1:"AU")
- OUT K ^TMP("LRAP",$J) D END^LRUTL,END Q
- ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
- B ;S LRI=$O(^LR(LRXREF,LRY,LRABV,LRAN,LRDFN,0)) D:$Y>(IOSL-6) H Q:LR("Q") D P W !,LRP,?36,SSN D EN^LRAPPF1 Q:LR("Q") W !,LR("%") Q
- S LRI=$O(^LR(LRXREF,LRY,LRABV,LRAN,LRDFN,0)) D:$Y>(IOSL-6) H Q:LR("Q") D P W !,LRP,?36,HRCN D EN^LRAPPF1 Q:LR("Q") W !,LR("%") Q ;IHS/ANMC/CLS 11/1/95
- ;----- END IHS MODIFICATIONS
- AU D P S SEX=$P(X,"^",2),Y=$P(X,"^",3),SSN=$P(X,"^",9) D D^LRU,SSN^LRU S DOB=$S(Y[1700:"",1:Y) D ^LRAPT2 Q
- ;
- P S X=^LR(LRDFN,0),Y=$P(X,"^",3),(LRDPF,X)=$P(X,"^",2),X=^DIC(X,0,"GL"),X=@(X_Y_",0)"),LRP=$P(X,"^"),SSN=$P(X,"^",9) D SSN^LRU Q
- H I $D(LR("F")),IOSL?1"C".E D M^LRU Q:LR("Q")
- D F^LRU W !?23,LRO(68)," CONSULTATIONS",!,LR("%") Q
- END D V^LRU Q
- ASK K A("B") W !,"Choice #",$J(B,2),": Select consultation code (must begin with 065): " R X:DTIME Q:X=""!(X[U) I X["ALL" S LRN(1)="065",LRM(1)=3 Q
- D CK^LRAUSM G:$D(A("B")) ASK I $E(X,1,3)'="065" W $C(7),!,"First 3 characters must be '065'" G ASK
- S LRN(X)=X,LRM(X)=$L(X) Q
- LRAPQACN ;AVAMC/REG - CONSULTATION RPTS ;8/12/95 12:05 [ 04/28/2003 12:10 PM ]
- +1 ;;5.2T9;LR;**1002,1008,1018**;Nov 17, 2004
- +2 ;;5.2;LAB SERVICE;**72,242,252**;Sep 27, 1994
- +3 WRITE !!,"Consultation search with report.",!,"This report may take a while and should be queued to print at non-peak hours.",!,"OK to continue "
- SET %=2
- DO YN^LRU
- IF %'=1
- GOTO END
- +4 DO ^LRAP
- IF '$DATA(Y)
- GOTO END
- SET LRN="065"
- FOR B=1:1
- DO ASK
- IF X[U!(X="")!(X["ALL")
- QUIT
- +5 IF B<2&(X="")
- GOTO END
- IF X=""&(B=2)
- SET LRN=$ORDER(LRQ(0))
- WRITE !
- +6 DO B^LRU
- IF Y<0
- GOTO END
- SET LRSDT=LRSDT-.01
- SET LRLDT=LRLDT+.99
- +7 SET ZTRTN="QUE^LRAPQACN"
- DO BEG^LRUTL
- IF POP!($DATA(ZTSK))
- GOTO END
- QUE USE IO
- KILL ^TMP($JOB),^TMP("LRAP",$JOB)
- SET S=LRSS
- SET LR("DIWF")="W"
- SET LRO=""
- SET (LR,LR("A"),LR(1),LR(2),LR(3))=0
- DO L^LRU
- DO S^LRU
- DO XR^LRU
- DO EN^LRUA
- +1 SET S(7)="PROCEDURE"
- SET LRSN=61.5
- SET V=4
- SET S(2)="ALL"
- +2 SET ^TMP($JOB,0)=S(2)_U_"FS"_U_LRO(68)_U_S(7)
- +3 FOR X=0:0
- SET LRSDT=$ORDER(^LR(LRXR,LRSDT))
- IF 'LRSDT!(LRSDT>LRLDT)
- QUIT
- DO @($SELECT(LRSS="AU":"LRDFN^LRAUSM",1:"LRDFN^LRAPSM"))
- +4 DO ^LRAPSM1
- DO EN2^LRUA
- DO SET^LRUA
- DO S^LRU
- SET (LRS(5),LR("W"),LRQ(3),LRQ(9),LRA)=1
- +5 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
- Y2K ;IHS/DIR/FJE
- SET LRTMPA=$GET(DT)
- SET LRTMPA=$SELECT($EXTRACT(LRTMPA,1)=2:200,1:300)
- +1 ;F A=0:0 S A=$O(^TMP($J,A)) Q:'A S X=A,%DT="" D ^%DT S LRY=$E(X,1,3) F B=0:0 S B=$O(^TMP($J,A,B)) Q:'B S ^TMP("LRAP",$J,LRY,B)=""
- +2 ;IHS/DIR/FJE
- FOR A=0:0
- SET A=$ORDER(^TMP($JOB,A))
- IF 'A
- QUIT
- SET LRY=A+LRTMPA
- FOR B=0:0
- SET B=$ORDER(^TMP($JOB,A,B))
- IF 'B
- QUIT
- SET ^TMP("LRAP",$JOB,LRY,B)=""
- +3 ;----- END IHS MODIFICATIONS
- +4 IF LRSS'="AU"
- DO H
- SET LRQ(3)=1
- SET LR("F")=1
- +5 FOR LRY=0:0
- SET LRY=$ORDER(^TMP("LRAP",$JOB,LRY))
- IF 'LRY!(LR("Q"))
- QUIT
- FOR LRAN=0:0
- SET LRAN=$ORDER(^TMP("LRAP",$JOB,LRY,LRAN))
- IF 'LRAN!(LR("Q"))
- QUIT
- SET LRDFN=$ORDER(^LR(LRXREF,LRY,LRABV,LRAN,0))
- DO @$SELECT(LRSS'="AU":"B",1:"AU")
- OUT KILL ^TMP("LRAP",$JOB)
- DO END^LRUTL
- DO END
- QUIT
- +1 ;----- BEGIN IHS MODIFICATIONS LR*5.2*1018
- B ;S LRI=$O(^LR(LRXREF,LRY,LRABV,LRAN,LRDFN,0)) D:$Y>(IOSL-6) H Q:LR("Q") D P W !,LRP,?36,SSN D EN^LRAPPF1 Q:LR("Q") W !,LR("%") Q
- +1 ;IHS/ANMC/CLS 11/1/95
- SET LRI=$ORDER(^LR(LRXREF,LRY,LRABV,LRAN,LRDFN,0))
- IF $Y>(IOSL-6)
- DO H
- IF LR("Q")
- QUIT
- DO P
- WRITE !,LRP,?36,HRCN
- DO EN^LRAPPF1
- IF LR("Q")
- QUIT
- WRITE !,LR("%")
- QUIT
- +2 ;----- END IHS MODIFICATIONS
- AU DO P
- SET SEX=$PIECE(X,"^",2)
- SET Y=$PIECE(X,"^",3)
- SET SSN=$PIECE(X,"^",9)
- DO D^LRU
- DO SSN^LRU
- SET DOB=$SELECT(Y[1700:"",1:Y)
- DO ^LRAPT2
- QUIT
- +1 ;
- P SET X=^LR(LRDFN,0)
- SET Y=$PIECE(X,"^",3)
- SET (LRDPF,X)=$PIECE(X,"^",2)
- SET X=^DIC(X,0,"GL")
- SET X=@(X_Y_",0)")
- SET LRP=$PIECE(X,"^")
- SET SSN=$PIECE(X,"^",9)
- DO SSN^LRU
- QUIT
- H IF $DATA(LR("F"))
- IF IOSL?1"C".E
- DO M^LRU
- IF LR("Q")
- QUIT
- +1 DO F^LRU
- WRITE !?23,LRO(68)," CONSULTATIONS",!,LR("%")
- QUIT
- END DO V^LRU
- QUIT
- ASK KILL A("B")
- WRITE !,"Choice #",$JUSTIFY(B,2),": Select consultation code (must begin with 065): "
- READ X:DTIME
- IF X=""!(X[U)
- QUIT
- IF X["ALL"
- SET LRN(1)="065"
- SET LRM(1)=3
- QUIT
- +1 DO CK^LRAUSM
- IF $DATA(A("B"))
- GOTO ASK
- IF $EXTRACT(X,1,3)'="065"
- WRITE $CHAR(7),!,"First 3 characters must be '065'"
- GOTO ASK
- +2 SET LRN(X)=X
- SET LRM(X)=$LENGTH(X)
- QUIT
