- LRARCR2 ;DALISC/CKA - CLONED WKLD REP GENERATOR-BUILD FOR ARCHIVING;5/8/95
- ;;5.2;LAB SERVICE;**59**;Aug 31, 1995
- ;same as LRCAPR2 except archived wkld file
- S:$D(ZTQUEUED) ZTREQ="@"
- K ^TMP("LRAR",$J) D DATE,^LRARCR3
- Q
- DATE ;
- I LRTO<LRFR S X=LRFR,LRFR=LRTO,LRTO=X
- S LRST=LRFR-.000001
- F S LRST=$O(^LRO(68,LRAA,1,LRST)) Q:'LRST!(LRST>LRTO) D
- . S LRNT=0
- . F S LRNT=$O(^LRO(68,LRAA,1,LRST,1,LRNT)) Q:'LRNT D ACC
- Q
- ACC ;
- S LRACCREC=$G(^LRO(68,LRAA,1,LRST,1,LRNT,0)) Q:LRACCREC=""
- S LRFIL=+$P(LRACCREC,U,2) Q:'LRFIL Q:(LRFIL>67.0)&(LRFIL<67.9999)
- S LRLTYP=$P(LRACCREC,U,11)
- S LRPATOK=$$CHKPAT(LRIOPAT,LRLTYP,LRFIL) Q:'+LRPATOK
- S LRPTYP=$E(LRPATOK,2)
- S LRLC=+$P(LRACCREC,U,13) I LRLOC Q:'$D(LRLOC(LRLC))!(LRLC<1)
- S:+LRLC LRLC=$P($G(^SC(LRLC,0)),U) S:LRLC="" LRLC="*MISSING LOC*"
- S LRAANO=$S($D(^LRO(68,LRAA,1,LRST,1,LRNT,.2)):^(.2),1:"NO ACCN")
- S LRSTCS=$G(^LRO(68,LRAA,1,LRST,1,LRNT,5,1,0)) Q:'LRSTCS
- I LRSP Q:'$P(LRSTCS,U) Q:'$D(LRSP($P(LRSTCS,U)))
- I LRCOL Q:'$P(LRSTCS,U,2) Q:'$D(LRCOL($P(LRSTCS,U,2)))
- S LRTST=0
- F S LRTST=$O(^LRO(68,LRAA,1,LRST,1,LRNT,4,LRTST)) Q:'LRTST D TEST
- Q
- TEST ;
- I LRTSTS,'$D(LRTSTS(LRTST)) Q
- Q:'$D(^LRO(68,LRAA,1,LRST,1,LRNT,4,LRTST,0))#2 S LRNX=^(0) Q:'$P(LRNX,U,5)
- S LRNX5=$P(LRNX,U,5),LRNX5D=$P(LRNX5,"."),LRURG=$P(LRNX,U,2)
- I $G(LRSTAT) Q:LRURG="" Q:'$D(LRSTAT(LRURG))#2
- S LRURGNAM=$S(LRURG="":"",$D(LRSTAT(LRURG))#2:LRSTAT(LRURG),1:"")
- S LRTEST=$$TST(LRTST)
- S LRNX5=$S($L(LRTOV,".")=1:$P(LRNX5,"."),1:LRNX5)
- S LRCPN=0 D LRCC
- Q
- LRCC ;
- S LRCPN=$O(^LRO(68,LRAA,1,LRST,1,LRNT,4,LRTST,1,LRCPN)) Q:'LRCPN S LRNODE=$G(^(LRCPN,0)) G:'LRNODE LRCC
- I LRSITSEL,'$D(LRSITSEL(+$P(LRNODE,U,8))) G LRCC
- I LRCAPS,'$D(LRCAPS(+LRNODE)) G LRCC
- S LRCAPNAM=$$WKLDNAME^LRARCU(+LRNODE)
- I (LRRTYP=2)&('LRCAPFLG) G LRCC
- I (LRRTYP=3)&(LRCAPFLG) G LRCC
- S:(LRCAPFLG)&($E(LRTEST)'="+") LRTEST="+"_LRTEST
- S LRCP=LRCAPNUM G:'LRCP LRCC
- S LRDOT="."_$P(LRCP,".",2)
- S LRTESTCP=$E(LRTEST_" ",1,8)_" ["_LRCP_"]"
- I LRCPSX,'$D(LRCPSX(LRDOT)) G LRCC
- S LRMACN=+$O(^LAB(64.2,"F",LRDOT,0))
- S LRMAC=$S($L($G(^LAB(64.2,LRMACN,0))):$P(^(0),U),1:"ERROR"_LRMACN)
- S:'$D(^TMP("LRAR",$J,"TST/TOT")) ^("TST/TOT")=0 S ^("TST/TOT")=^("TST/TOT")+1
- S:'$D(^TMP("LRAR",$J,"TST",LRTEST)) ^(LRTEST)=0 S ^(LRTEST)=^(LRTEST)+1
- S:'$D(^TMP("LRAR",$J,"TST",LRTEST,LRLC)) ^(LRLC)=0 S ^(LRLC)=^(LRLC)+1
- S:'$D(^TMP("LRAR",$J,"TST",LRTEST,LRLC,LRCP)) ^(LRCP)=0 S ^(LRCP)=^(LRCP)+1,J=^(LRCP)
- S ^TMP("LRAR",$J,"TST",LRTEST,LRLC,LRCP,LRAANO,(J+1))=LRNX5_U_LRMAC_U_LRURGNAM
- S:'$D(^TMP("LRAR",$J,"TST/LOC",LRLC)) ^(LRLC)=0 S ^(LRLC)=^(LRLC)+1
- S:'$D(^TMP("LRAR",$J,"TST/LRM",LRMAC)) ^(LRMAC)=0 S ^(LRMAC)=^(LRMAC)+1
- S:'$D(^TMP("LRAR",$J,"TST/LRM",LRMAC,LRTESTCP)) ^(LRTESTCP)=0 S ^(LRTESTCP)=^(LRTESTCP)+1
- I LRCNTL D
- . S:'$D(^TMP("LRAR",$J,"TST/CTL",LRMAC)) ^(LRMAC)=0 S ^(LRMAC)=^(LRMAC)+1
- . S:'$D(^TMP("LRAR",$J,"TST/CTL",LRMAC,LRTESTCP)) ^(LRTESTCP)=0 S ^(LRTESTCP)=^(LRTESTCP)+1
- I LRURGNAM'="" D
- . S:'$D(^TMP("LRAR",$J,"TST/URG",LRPTYP,LRURGNAM)) ^(LRURGNAM)=0 S ^(LRURGNAM)=^(LRURGNAM)+1
- . S:'$D(^TMP("LRAR",$J,"TST/URG",LRPTYP,LRURGNAM,LRTEST)) ^(LRTEST)=0 S ^(LRTEST)=^(LRTEST)+1
- . S:'$D(^TMP("LRAR",$J,"TST/URG","A",LRURGNAM)) ^(LRURGNAM)=0 S ^(LRURGNAM)=^(LRURGNAM)+1
- . S:'$D(^TMP("LRAR",$J,"TST/URG","A",LRURGNAM,LRTEST)) ^(LRTEST)=0 S ^(LRTEST)=^(LRTEST)+1
- S:'$D(^TMP("LRAR",$J,"DATE",LRNX5D)) ^(LRNX5D)=0 S ^(LRNX5D)=^(LRNX5D)+1
- S:'$D(^TMP("LRAR",$J,"DATE",LRNX5D,LRTESTCP)) ^(LRTESTCP)=0 S ^(LRTESTCP)=^(LRTESTCP)+1
- S:'$D(^TMP("LRAR",$J,"DAY",LRNX5D)) ^(LRNX5D)=0 S ^(LRNX5D)=^(LRNX5D)+1
- S:'$D(^TMP("LRAR",$J,"DAY",LRNX5D,LRMAC)) ^(LRMAC)=0 S ^(LRMAC)=^(LRMAC)+1
- S:'$D(^TMP("LRAR",$J,"DAY",LRNX5D,LRMAC,LRTESTCP)) ^(LRTESTCP)=0 S ^(LRTESTCP)=^(LRTESTCP)+1,J=^(LRTESTCP)
- G LRCC
- Q
- TST(X) ; this returns the print test name otherwise the test name.
- N LRDA
- ;tests are truncated if greater than 7 chars long
- S LRDA=$G(X) Q:'LRDA "Unknown"
- Q:'$D(^LAB(60,LRDA,0))#2 "Unknown"
- Q:$P($G(^LAB(60,LRDA,.1)),U)'="" $P($G(^(.1)),U)
- Q $S($L($P(^LAB(60,LRDA,0),U))>7:$E($P(^LAB(60,LRDA,0),U),1,6)_"*",1:$P(^LAB(60,LRDA,0),U))
- CHKPAT(LRIOPAT,LRLTYP,LRFIL) ; return flag indicating if this record is for
- ; a patient type selected for this report and if so, what type.
- S LRCNTL=$S(LRFIL=62.3:1,1:0)
- I ("OW"[LRLTYP)&((LRFIL=2)!(LRFIL=67))&(LRIOPAT["I") Q "1I" ; Inpatient
- I ("OW"'[LRLTYP)&((LRFIL=2)!(LRFIL=67))&(LRIOPAT["O") Q "1O" ; Outpatient
- I (LRIOPAT["R") Q "1R" ; Other
- Q 0
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRARCR2 4527 printed Jan 18, 2025@03:10:01 Page 2
- LRARCR2 ;DALISC/CKA - CLONED WKLD REP GENERATOR-BUILD FOR ARCHIVING;5/8/95
- +1 ;;5.2;LAB SERVICE;**59**;Aug 31, 1995
- +2 ;same as LRCAPR2 except archived wkld file
- +3 if $DATA(ZTQUEUED)
- SET ZTREQ="@"
- +4 KILL ^TMP("LRAR",$JOB)
- DO DATE
- DO ^LRARCR3
- +5 QUIT
- DATE ;
- +1 IF LRTO<LRFR
- SET X=LRFR
- SET LRFR=LRTO
- SET LRTO=X
- +2 SET LRST=LRFR-.000001
- +3 FOR
- SET LRST=$ORDER(^LRO(68,LRAA,1,LRST))
- if 'LRST!(LRST>LRTO)
- QUIT
- Begin DoDot:1
- +4 SET LRNT=0
- +5 FOR
- SET LRNT=$ORDER(^LRO(68,LRAA,1,LRST,1,LRNT))
- if 'LRNT
- QUIT
- DO ACC
- End DoDot:1
- +6 QUIT
- ACC ;
- +1 SET LRACCREC=$GET(^LRO(68,LRAA,1,LRST,1,LRNT,0))
- if LRACCREC=""
- QUIT
- +2 SET LRFIL=+$PIECE(LRACCREC,U,2)
- if 'LRFIL
- QUIT
- if (LRFIL>67.0)&(LRFIL<67.9999)
- QUIT
- +3 SET LRLTYP=$PIECE(LRACCREC,U,11)
- +4 SET LRPATOK=$$CHKPAT(LRIOPAT,LRLTYP,LRFIL)
- if '+LRPATOK
- QUIT
- +5 SET LRPTYP=$EXTRACT(LRPATOK,2)
- +6 SET LRLC=+$PIECE(LRACCREC,U,13)
- IF LRLOC
- if '$DATA(LRLOC(LRLC))!(LRLC<1)
- QUIT
- +7 if +LRLC
- SET LRLC=$PIECE($GET(^SC(LRLC,0)),U)
- if LRLC=""
- SET LRLC="*MISSING LOC*"
- +8 SET LRAANO=$SELECT($DATA(^LRO(68,LRAA,1,LRST,1,LRNT,.2)):^(.2),1:"NO ACCN")
- +9 SET LRSTCS=$GET(^LRO(68,LRAA,1,LRST,1,LRNT,5,1,0))
- if 'LRSTCS
- QUIT
- +10 IF LRSP
- if '$PIECE(LRSTCS,U)
- QUIT
- if '$DATA(LRSP($PIECE(LRSTCS,U)))
- QUIT
- +11 IF LRCOL
- if '$PIECE(LRSTCS,U,2)
- QUIT
- if '$DATA(LRCOL($PIECE(LRSTCS,U,2)))
- QUIT
- +12 SET LRTST=0
- +13 FOR
- SET LRTST=$ORDER(^LRO(68,LRAA,1,LRST,1,LRNT,4,LRTST))
- if 'LRTST
- QUIT
- DO TEST
- +14 QUIT
- TEST ;
- +1 IF LRTSTS
- IF '$DATA(LRTSTS(LRTST))
- QUIT
- +2 if '$DATA(^LRO(68,LRAA,1,LRST,1,LRNT,4,LRTST,0))#2
- QUIT
- SET LRNX=^(0)
- if '$PIECE(LRNX,U,5)
- QUIT
- +3 SET LRNX5=$PIECE(LRNX,U,5)
- SET LRNX5D=$PIECE(LRNX5,".")
- SET LRURG=$PIECE(LRNX,U,2)
- +4 IF $GET(LRSTAT)
- if LRURG=""
- QUIT
- if '$DATA(LRSTAT(LRURG))#2
- QUIT
- +5 SET LRURGNAM=$SELECT(LRURG="":"",$DATA(LRSTAT(LRURG))#2:LRSTAT(LRURG),1:"")
- +6 SET LRTEST=$$TST(LRTST)
- +7 SET LRNX5=$SELECT($LENGTH(LRTOV,".")=1:$PIECE(LRNX5,"."),1:LRNX5)
- +8 SET LRCPN=0
- DO LRCC
- +9 QUIT
- LRCC ;
- +1 SET LRCPN=$ORDER(^LRO(68,LRAA,1,LRST,1,LRNT,4,LRTST,1,LRCPN))
- if 'LRCPN
- QUIT
- SET LRNODE=$GET(^(LRCPN,0))
- if 'LRNODE
- GOTO LRCC
- +2 IF LRSITSEL
- IF '$DATA(LRSITSEL(+$PIECE(LRNODE,U,8)))
- GOTO LRCC
- +3 IF LRCAPS
- IF '$DATA(LRCAPS(+LRNODE))
- GOTO LRCC
- +4 SET LRCAPNAM=$$WKLDNAME^LRARCU(+LRNODE)
- +5 IF (LRRTYP=2)&('LRCAPFLG)
- GOTO LRCC
- +6 IF (LRRTYP=3)&(LRCAPFLG)
- GOTO LRCC
- +7 if (LRCAPFLG)&($EXTRACT(LRTEST)'="+")
- SET LRTEST="+"_LRTEST
- +8 SET LRCP=LRCAPNUM
- if 'LRCP
- GOTO LRCC
- +9 SET LRDOT="."_$PIECE(LRCP,".",2)
- +10 SET LRTESTCP=$EXTRACT(LRTEST_" ",1,8)_" ["_LRCP_"]"
- +11 IF LRCPSX
- IF '$DATA(LRCPSX(LRDOT))
- GOTO LRCC
- +12 SET LRMACN=+$ORDER(^LAB(64.2,"F",LRDOT,0))
- +13 SET LRMAC=$SELECT($LENGTH($GET(^LAB(64.2,LRMACN,0))):$PIECE(^(0),U),1:"ERROR"_LRMACN)
- +14 if '$DATA(^TMP("LRAR",$JOB,"TST/TOT"))
- SET ^("TST/TOT")=0
- SET ^("TST/TOT")=^("TST/TOT")+1
- +15 if '$DATA(^TMP("LRAR",$JOB,"TST",LRTEST))
- SET ^(LRTEST)=0
- SET ^(LRTEST)=^(LRTEST)+1
- +16 if '$DATA(^TMP("LRAR",$JOB,"TST",LRTEST,LRLC))
- SET ^(LRLC)=0
- SET ^(LRLC)=^(LRLC)+1
- +17 if '$DATA(^TMP("LRAR",$JOB,"TST",LRTEST,LRLC,LRCP))
- SET ^(LRCP)=0
- SET ^(LRCP)=^(LRCP)+1
- SET J=^(LRCP)
- +18 SET ^TMP("LRAR",$JOB,"TST",LRTEST,LRLC,LRCP,LRAANO,(J+1))=LRNX5_U_LRMAC_U_LRURGNAM
- +19 if '$DATA(^TMP("LRAR",$JOB,"TST/LOC",LRLC))
- SET ^(LRLC)=0
- SET ^(LRLC)=^(LRLC)+1
- +20 if '$DATA(^TMP("LRAR",$JOB,"TST/LRM",LRMAC))
- SET ^(LRMAC)=0
- SET ^(LRMAC)=^(LRMAC)+1
- +21 if '$DATA(^TMP("LRAR",$JOB,"TST/LRM",LRMAC,LRTESTCP))
- SET ^(LRTESTCP)=0
- SET ^(LRTESTCP)=^(LRTESTCP)+1
- +22 IF LRCNTL
- Begin DoDot:1
- +23 if '$DATA(^TMP("LRAR",$JOB,"TST/CTL",LRMAC))
- SET ^(LRMAC)=0
- SET ^(LRMAC)=^(LRMAC)+1
- +24 if '$DATA(^TMP("LRAR",$JOB,"TST/CTL",LRMAC,LRTESTCP))
- SET ^(LRTESTCP)=0
- SET ^(LRTESTCP)=^(LRTESTCP)+1
- End DoDot:1
- +25 IF LRURGNAM'=""
- Begin DoDot:1
- +26 if '$DATA(^TMP("LRAR",$JOB,"TST/URG",LRPTYP,LRURGNAM))
- SET ^(LRURGNAM)=0
- SET ^(LRURGNAM)=^(LRURGNAM)+1
- +27 if '$DATA(^TMP("LRAR",$JOB,"TST/URG",LRPTYP,LRURGNAM,LRTEST))
- SET ^(LRTEST)=0
- SET ^(LRTEST)=^(LRTEST)+1
- +28 if '$DATA(^TMP("LRAR",$JOB,"TST/URG","A",LRURGNAM))
- SET ^(LRURGNAM)=0
- SET ^(LRURGNAM)=^(LRURGNAM)+1
- +29 if '$DATA(^TMP("LRAR",$JOB,"TST/URG","A",LRURGNAM,LRTEST))
- SET ^(LRTEST)=0
- SET ^(LRTEST)=^(LRTEST)+1
- End DoDot:1
- +30 if '$DATA(^TMP("LRAR",$JOB,"DATE",LRNX5D))
- SET ^(LRNX5D)=0
- SET ^(LRNX5D)=^(LRNX5D)+1
- +31 if '$DATA(^TMP("LRAR",$JOB,"DATE",LRNX5D,LRTESTCP))
- SET ^(LRTESTCP)=0
- SET ^(LRTESTCP)=^(LRTESTCP)+1
- +32 if '$DATA(^TMP("LRAR",$JOB,"DAY",LRNX5D))
- SET ^(LRNX5D)=0
- SET ^(LRNX5D)=^(LRNX5D)+1
- +33 if '$DATA(^TMP("LRAR",$JOB,"DAY",LRNX5D,LRMAC))
- SET ^(LRMAC)=0
- SET ^(LRMAC)=^(LRMAC)+1
- +34 if '$DATA(^TMP("LRAR",$JOB,"DAY",LRNX5D,LRMAC,LRTESTCP))
- SET ^(LRTESTCP)=0
- SET ^(LRTESTCP)=^(LRTESTCP)+1
- SET J=^(LRTESTCP)
- +35 GOTO LRCC
- +36 QUIT
- TST(X) ; this returns the print test name otherwise the test name.
- +1 NEW LRDA
- +2 ;tests are truncated if greater than 7 chars long
- +3 SET LRDA=$GET(X)
- if 'LRDA
- QUIT "Unknown"
- +4 if '$DATA(^LAB(60,LRDA,0))#2
- QUIT "Unknown"
- +5 if $PIECE($GET(^LAB(60,LRDA,.1)),U)'=""
- QUIT $PIECE($GET(^(.1)),U)
- +6 QUIT $SELECT($LENGTH($PIECE(^LAB(60,LRDA,0),U))>7:$EXTRACT($PIECE(^LAB(60,LRDA,0),U),1,6)_"*",1:$PIECE(^LAB(60,LRDA,0),U))
- CHKPAT(LRIOPAT,LRLTYP,LRFIL) ; return flag indicating if this record is for
- +1 ; a patient type selected for this report and if so, what type.
- +2 SET LRCNTL=$SELECT(LRFIL=62.3:1,1:0)
- +3 ; Inpatient
- IF ("OW"[LRLTYP)&((LRFIL=2)!(LRFIL=67))&(LRIOPAT["I")
- QUIT "1I"
- +4 ; Outpatient
- IF ("OW"'[LRLTYP)&((LRFIL=2)!(LRFIL=67))&(LRIOPAT["O")
- QUIT "1O"
- +5 ; Other
- IF (LRIOPAT["R")
- QUIT "1R"
- +6 QUIT 0