BWLABLG ;IHS/ANMC/MWR - DISPLAY LAB LOG;15-Feb-2003 21:55;PLS
;;2.0;WOMEN'S HEALTH;**8**;MAY 16, 1996
;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
;; CALLED BY OPTION: "BW LAB PRINT LOG" TO PRINT THE "LOG" OF
;; OF PROCEDURES THAT HAVE BEEN ENTERED ("ACCESSIONED").
;
;---> VARIABLES:
;---> DATES: BWBEGDT=BEGINNING DATE, BWENDDT=ENDING DATE
;---> BWA: 1=ALL PROCEDURES, 0=ONLY PROCEDURES WITHOUT RESULTS
;---> BWB: 1=DISPLAY EACH PROCEDURE, 0=TOTALS ONLY
;
D SETVARS^BWUTL5 S BWPOP=0
D TITLE^BWUTL5("PRINT LOG OF PROCEDURES ENTRY")
D DATES G:BWPOP EXIT
D SELECT G:BWPOP EXIT
D FACILITY G:BWPOP EXIT
D RESULT G:BWPOP EXIT
D TOTALS G:BWPOP EXIT
D ORDER G:BWPOP EXIT
D DEVICE G:BWPOP EXIT
D SORT
D COPYGBL
D ^BWLABLG1
;
EXIT ;EP
D KILLALL^BWUTL8
Q
;
DATES ;EP
;---> ASK DATE RANGE. RETURN DATES IN BWBEGDT AND BWENDDT.
;---> LAB PEOPLE GENERALLY LOOK AT THE LOG FOR ONE DAY.
D ASKDATES^BWUTL3(.BWBEGDT,.BWENDDT,.BWPOP,"T-1","",1)
Q
;
SELECT ;EP
;---> SELECT ENTRIES TO SEARCH FOR.
D SELECT^BWSELECT("Accession Area",9002086.2,"BWAREA","","PAP",.BWPOP)
Q
;
FACILITY ;EP
;---> SELECT FACILITY TO SEARCH FOR.
N B S B=$$INSTTX^BWUTL6(DUZ(2))
W !!?3,"Select the Facility for the log you wish to display."
D DIC^BWFMAN(9002086.02,"QEMA",.Y," Select FACILITY: ",B)
I Y<0 S BWPOP=1 Q
S BWFAC=+Y
Q
;
RESULT ;EP
;---> DISPLAY ALL PROCEDURES, OR ONLY PROCEDURES WITHOUT RESULTS.
N DIR K DIRUT
W !!?3,"Display ALL Procedures, or only Procedures with NO RESULTS?"
S DIR("A")=" Select ALL or NO RESULTS: ",DIR("B")="ALL"
S DIR(0)="SAM^a:ALL;n:NO RESULTS" D HELP1^BWLABLG2
D ^DIR
I Y=-1!($D(DIRUT)) S BWPOP=1 Q
;---> IF ALL PPROCEDURES, S BWA=1; IF ONLY NO RESULTS, S BWA=0.
S BWA=$S(Y="a":1,1:0)
Q
;
TOTALS ;EP
;---> DISPLAY ALL PROCEDURES, OR ONLY TOTALS.
N DIR
W !!?3,"Display data for EACH Procedure, or just TOTALS?"
S DIR("A")=" Select EACH or TOTALS: ",DIR("B")="EACH"
S DIR(0)="SAM^e:EACH;n:TOTALS" D HELP2^BWLABLG2
D ^DIR
I Y=-1!($D(DIRUT)) S BWPOP=1 Q
;---> IF DISPLAY EACH PROCEDURE, S BWB=1; IF TOTALS ONLY, S BWB=0
S BWB=$S(Y="e":1,1:0)
Q
;
ORDER ;EP
;---> ASK ORDER BY ACCESSION# OR BY PATIENT NAME.
;---> SORT SEQUENCE IN BWC: 1=ACCESSION# (DEFAULT), 2=PATIENT NAME
S BWC=1
;---> QUIT IF DISPLAYING TOTALS ONLY.
Q:'BWB N DIR,DIRUT,Y
W !!?3,"Display Procedures in order of:"
W ?37,"1) ACCESSION# (earliest first)"
W !?37,"2) PATIENT NAME (alphabetically)"
S DIR("A")=" Select 1 or 2: ",DIR("B")=1
S DIR(0)="SAM^1:ACCESSION#;2:PATIENT NAME" D HELP3^BWLABLG2
D ^DIR
I Y=-1!($D(DIRUT)) S BWPOP=1 Q
S BWC=Y
Q
;
DEVICE ;EP
;---> GET DEVICE AND POSSIBLY QUEUE TO TASKMAN.
S ZTRTN="DEQUEUE^BWLABLG"
F BWSV="A","B","C","BEGDT","ENDDT","FAC" D
.I $D(@("BW"_BWSV)) S ZTSAVE("BW"_BWSV)=""
;---> SAVE ATTRIBUTES ARRAY. NOTE: SUBSTITUTE LOCAL ARRAY FOR BWAREA.
I $D(BWAREA) N N S N=0 F S N=$O(BWAREA(N)) Q:N="" D
.S ZTSAVE("BWAREA("""_N_""")")=""
D ZIS^BWUTL2(.BWPOP,1)
Q
;
SORT ;EP
;---> SORT AND STORE ARRAY IN ^TMP("BW",$J
;---> BWBEGDT1=ONE SECOND BEFORE BEGIN DATE.
;---> BWENDDT1=THE LAST SECOND OF END DATE.
;
K ^TMP("BW",$J)
S BWBEGDT1=BWBEGDT-.0001,BWENDDT1=BWENDDT+.9999
S BWDATE=BWBEGDT1
F S BWDATE=$O(^BWPCD("ADE",BWDATE)) Q:'BWDATE!(BWDATE>BWENDDT1) D
.S BWIEN=0
.F S BWIEN=$O(^BWPCD("ADE",BWDATE,BWIEN)) Q:'BWIEN D
..S Y=^BWPCD(BWIEN,0),BWDFN=$P(Y,U,2)
..;---> QUIT IF NOT DONE AT THE SELECTED FACILITY.
..Q:$P(Y,U,34)'=BWFAC
..;---> QUIT IF NOT ALL "ACCESSION AREAS" (PROCEDURE TYPES) AND
..;---> THIS DOES NOT MATCH THE SELECTED AREA.
..I '$D(BWAREA("ALL")) Q:$P(Y,U,4)="" Q:'$D(BWAREA($P(Y,U,4)))
..D STORE
Q
;
;
STORE ;EP
;--->BWDATE IS ALREADY SET FROM LL SORT ABOVE. ;---> DATE
S BWCHRT=$$HRCN^BWUTL1(BWDFN) ;---> CHART#
S BWNAME=$$NAME^BWUTL1(BWDFN) ;---> NAME
S BWACCN=$P(Y,U) ;---> ACCESSION#
S X=$P(Y,U,4),BWPCDN=$$PCDNAM^BWUTL6 ;---> PROC TYPE
S BWDIAG=$$DIAG^BWUTL4($P(Y,U,5)) ;---> RESULT/DIAG
S BWRES=$O(^BWPCD(BWIEN,1,0)) ;---> RESULT TEXT
;---> QUIT IF DISPLAYING ONLY PROCEDURES WITH NO RESULTS.
Q:'BWA&($P(Y,U,5))
S BWPDATE=$$SLDT2^BWUTL5($P(Y,U,12)) ;---> PROC DATE
S BWRCVDT=$$SLDT2^BWUTL5($P(Y,U,17)) ;---> RCV RES DAT
S X=$P(Y,U,11),BWHLOC=$$HOSPLC^BWUTL6 ;---> HOSP LOC
S X=$P(Y,U,7),BWPROV=$$PROV^BWUTL6 ;---> PROVIDER
S X=$P(Y,U,18),BWUSER=$$PROV^BWUTL6 ;---> ENTERED BY
;
S X=BWCHRT_U_BWNAME_U_BWDATE_U_BWACCN_U_BWPCDN_U_BWRES_U_BWPDATE
S X=X_U_BWHLOC_U_BWPROV_U_BWUSER_U_BWRCVDT_U_BWDIAG_U_BWIEN
I BWC=1 S ^TMP("BW",$J,1,BWDATE,$P(BWACCN,"-"),$P(BWACCN,"-",2))=X Q
I BWC=2 S ^TMP("BW",$J,1,BWDATE,BWNAME,BWACCN)=X Q
Q
;
COPYGBL ;EP
;---> COPY ^TMP("BW",$J,1 TO ^TMP("BW",$J,2 TO MAKE IT FLAT.
N I,M,N,P,Q
S N=0,I=0
F S N=$O(^TMP("BW",$J,1,N)) Q:N="" D
.S M=0
.F S M=$O(^TMP("BW",$J,1,N,M)) Q:M="" D
..S P=0
..F S P=$O(^TMP("BW",$J,1,N,M,P)) Q:P="" D
...S I=I+1,^TMP("BW",$J,2,I)=^TMP("BW",$J,1,N,M,P)
Q
;
DEQUEUE ;EP
;---> TASKMAN QUEUE OF PRINTOUT.
D SETVARS^BWUTL5,SORT,COPYGBL,^BWLABLG1,EXIT
Q
BWLABLG ;IHS/ANMC/MWR - DISPLAY LAB LOG;15-Feb-2003 21:55;PLS
+1 ;;2.0;WOMEN'S HEALTH;**8**;MAY 16, 1996
+2 ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
+3 ;; CALLED BY OPTION: "BW LAB PRINT LOG" TO PRINT THE "LOG" OF
+4 ;; OF PROCEDURES THAT HAVE BEEN ENTERED ("ACCESSIONED").
+5 ;
+6 ;---> VARIABLES:
+7 ;---> DATES: BWBEGDT=BEGINNING DATE, BWENDDT=ENDING DATE
+8 ;---> BWA: 1=ALL PROCEDURES, 0=ONLY PROCEDURES WITHOUT RESULTS
+9 ;---> BWB: 1=DISPLAY EACH PROCEDURE, 0=TOTALS ONLY
+10 ;
+11 DO SETVARS^BWUTL5
SET BWPOP=0
+12 DO TITLE^BWUTL5("PRINT LOG OF PROCEDURES ENTRY")
+13 DO DATES
IF BWPOP
GOTO EXIT
+14 DO SELECT
IF BWPOP
GOTO EXIT
+15 DO FACILITY
IF BWPOP
GOTO EXIT
+16 DO RESULT
IF BWPOP
GOTO EXIT
+17 DO TOTALS
IF BWPOP
GOTO EXIT
+18 DO ORDER
IF BWPOP
GOTO EXIT
+19 DO DEVICE
IF BWPOP
GOTO EXIT
+20 DO SORT
+21 DO COPYGBL
+22 DO ^BWLABLG1
+23 ;
EXIT ;EP
+1 DO KILLALL^BWUTL8
+2 QUIT
+3 ;
DATES ;EP
+1 ;---> ASK DATE RANGE. RETURN DATES IN BWBEGDT AND BWENDDT.
+2 ;---> LAB PEOPLE GENERALLY LOOK AT THE LOG FOR ONE DAY.
+3 DO ASKDATES^BWUTL3(.BWBEGDT,.BWENDDT,.BWPOP,"T-1","",1)
+4 QUIT
+5 ;
SELECT ;EP
+1 ;---> SELECT ENTRIES TO SEARCH FOR.
+2 DO SELECT^BWSELECT("Accession Area",9002086.2,"BWAREA","","PAP",.BWPOP)
+3 QUIT
+4 ;
FACILITY ;EP
+1 ;---> SELECT FACILITY TO SEARCH FOR.
+2 NEW B
SET B=$$INSTTX^BWUTL6(DUZ(2))
+3 WRITE !!?3,"Select the Facility for the log you wish to display."
+4 DO DIC^BWFMAN(9002086.02,"QEMA",.Y," Select FACILITY: ",B)
+5 IF Y<0
SET BWPOP=1
QUIT
+6 SET BWFAC=+Y
+7 QUIT
+8 ;
RESULT ;EP
+1 ;---> DISPLAY ALL PROCEDURES, OR ONLY PROCEDURES WITHOUT RESULTS.
+2 NEW DIR
KILL DIRUT
+3 WRITE !!?3,"Display ALL Procedures, or only Procedures with NO RESULTS?"
+4 SET DIR("A")=" Select ALL or NO RESULTS: "
SET DIR("B")="ALL"
+5 SET DIR(0)="SAM^a:ALL;n:NO RESULTS"
DO HELP1^BWLABLG2
+6 DO ^DIR
+7 IF Y=-1!($DATA(DIRUT))
SET BWPOP=1
QUIT
+8 ;---> IF ALL PPROCEDURES, S BWA=1; IF ONLY NO RESULTS, S BWA=0.
+9 SET BWA=$SELECT(Y="a":1,1:0)
+10 QUIT
+11 ;
TOTALS ;EP
+1 ;---> DISPLAY ALL PROCEDURES, OR ONLY TOTALS.
+2 NEW DIR
+3 WRITE !!?3,"Display data for EACH Procedure, or just TOTALS?"
+4 SET DIR("A")=" Select EACH or TOTALS: "
SET DIR("B")="EACH"
+5 SET DIR(0)="SAM^e:EACH;n:TOTALS"
DO HELP2^BWLABLG2
+6 DO ^DIR
+7 IF Y=-1!($DATA(DIRUT))
SET BWPOP=1
QUIT
+8 ;---> IF DISPLAY EACH PROCEDURE, S BWB=1; IF TOTALS ONLY, S BWB=0
+9 SET BWB=$SELECT(Y="e":1,1:0)
+10 QUIT
+11 ;
ORDER ;EP
+1 ;---> ASK ORDER BY ACCESSION# OR BY PATIENT NAME.
+2 ;---> SORT SEQUENCE IN BWC: 1=ACCESSION# (DEFAULT), 2=PATIENT NAME
+3 SET BWC=1
+4 ;---> QUIT IF DISPLAYING TOTALS ONLY.
+5 IF 'BWB
QUIT
NEW DIR,DIRUT,Y
+6 WRITE !!?3,"Display Procedures in order of:"
+7 WRITE ?37,"1) ACCESSION# (earliest first)"
+8 WRITE !?37,"2) PATIENT NAME (alphabetically)"
+9 SET DIR("A")=" Select 1 or 2: "
SET DIR("B")=1
+10 SET DIR(0)="SAM^1:ACCESSION#;2:PATIENT NAME"
DO HELP3^BWLABLG2
+11 DO ^DIR
+12 IF Y=-1!($DATA(DIRUT))
SET BWPOP=1
QUIT
+13 SET BWC=Y
+14 QUIT
+15 ;
DEVICE ;EP
+1 ;---> GET DEVICE AND POSSIBLY QUEUE TO TASKMAN.
+2 SET ZTRTN="DEQUEUE^BWLABLG"
+3 FOR BWSV="A","B","C","BEGDT","ENDDT","FAC"
Begin DoDot:1
+4 IF $DATA(@("BW"_BWSV))
SET ZTSAVE("BW"_BWSV)=""
End DoDot:1
+5 ;---> SAVE ATTRIBUTES ARRAY. NOTE: SUBSTITUTE LOCAL ARRAY FOR BWAREA.
+6 IF $DATA(BWAREA)
NEW N
SET N=0
FOR
SET N=$ORDER(BWAREA(N))
IF N=""
QUIT
Begin DoDot:1
+7 SET ZTSAVE("BWAREA("""_N_""")")=""
End DoDot:1
+8 DO ZIS^BWUTL2(.BWPOP,1)
+9 QUIT
+10 ;
SORT ;EP
+1 ;---> SORT AND STORE ARRAY IN ^TMP("BW",$J
+2 ;---> BWBEGDT1=ONE SECOND BEFORE BEGIN DATE.
+3 ;---> BWENDDT1=THE LAST SECOND OF END DATE.
+4 ;
+5 KILL ^TMP("BW",$JOB)
+6 SET BWBEGDT1=BWBEGDT-.0001
SET BWENDDT1=BWENDDT+.9999
+7 SET BWDATE=BWBEGDT1
+8 FOR
SET BWDATE=$ORDER(^BWPCD("ADE",BWDATE))
IF 'BWDATE!(BWDATE>BWENDDT1)
QUIT
Begin DoDot:1
+9 SET BWIEN=0
+10 FOR
SET BWIEN=$ORDER(^BWPCD("ADE",BWDATE,BWIEN))
IF 'BWIEN
QUIT
Begin DoDot:2
+11 SET Y=^BWPCD(BWIEN,0)
SET BWDFN=$PIECE(Y,U,2)
+12 ;---> QUIT IF NOT DONE AT THE SELECTED FACILITY.
+13 IF $PIECE(Y,U,34)'=BWFAC
QUIT
+14 ;---> QUIT IF NOT ALL "ACCESSION AREAS" (PROCEDURE TYPES) AND
+15 ;---> THIS DOES NOT MATCH THE SELECTED AREA.
+16 IF '$DATA(BWAREA("ALL"))
IF $PIECE(Y,U,4)=""
QUIT
IF '$DATA(BWAREA($PIECE(Y,U,4)))
QUIT
+17 DO STORE
End DoDot:2
End DoDot:1
+18 QUIT
+19 ;
+20 ;
STORE ;EP
+1 ;--->BWDATE IS ALREADY SET FROM LL SORT ABOVE. ;---> DATE
+2 ;---> CHART#
SET BWCHRT=$$HRCN^BWUTL1(BWDFN)
+3 ;---> NAME
SET BWNAME=$$NAME^BWUTL1(BWDFN)
+4 ;---> ACCESSION#
SET BWACCN=$PIECE(Y,U)
+5 ;---> PROC TYPE
SET X=$PIECE(Y,U,4)
SET BWPCDN=$$PCDNAM^BWUTL6
+6 ;---> RESULT/DIAG
SET BWDIAG=$$DIAG^BWUTL4($PIECE(Y,U,5))
+7 ;---> RESULT TEXT
SET BWRES=$ORDER(^BWPCD(BWIEN,1,0))
+8 ;---> QUIT IF DISPLAYING ONLY PROCEDURES WITH NO RESULTS.
+9 IF 'BWA&($PIECE(Y,U,5))
QUIT
+10 ;---> PROC DATE
SET BWPDATE=$$SLDT2^BWUTL5($PIECE(Y,U,12))
+11 ;---> RCV RES DAT
SET BWRCVDT=$$SLDT2^BWUTL5($PIECE(Y,U,17))
+12 ;---> HOSP LOC
SET X=$PIECE(Y,U,11)
SET BWHLOC=$$HOSPLC^BWUTL6
+13 ;---> PROVIDER
SET X=$PIECE(Y,U,7)
SET BWPROV=$$PROV^BWUTL6
+14 ;---> ENTERED BY
SET X=$PIECE(Y,U,18)
SET BWUSER=$$PROV^BWUTL6
+15 ;
+16 SET X=BWCHRT_U_BWNAME_U_BWDATE_U_BWACCN_U_BWPCDN_U_BWRES_U_BWPDATE
+17 SET X=X_U_BWHLOC_U_BWPROV_U_BWUSER_U_BWRCVDT_U_BWDIAG_U_BWIEN
+18 IF BWC=1
SET ^TMP("BW",$JOB,1,BWDATE,$PIECE(BWACCN,"-"),$PIECE(BWACCN,"-",2))=X
QUIT
+19 IF BWC=2
SET ^TMP("BW",$JOB,1,BWDATE,BWNAME,BWACCN)=X
QUIT
+20 QUIT
+21 ;
COPYGBL ;EP
+1 ;---> COPY ^TMP("BW",$J,1 TO ^TMP("BW",$J,2 TO MAKE IT FLAT.
+2 NEW I,M,N,P,Q
+3 SET N=0
SET I=0
+4 FOR
SET N=$ORDER(^TMP("BW",$JOB,1,N))
IF N=""
QUIT
Begin DoDot:1
+5 SET M=0
+6 FOR
SET M=$ORDER(^TMP("BW",$JOB,1,N,M))
IF M=""
QUIT
Begin DoDot:2
+7 SET P=0
+8 FOR
SET P=$ORDER(^TMP("BW",$JOB,1,N,M,P))
IF P=""
QUIT
Begin DoDot:3
+9 SET I=I+1
SET ^TMP("BW",$JOB,2,I)=^TMP("BW",$JOB,1,N,M,P)
End DoDot:3
End DoDot:2
End DoDot:1
+10 QUIT
+11 ;
DEQUEUE ;EP
+1 ;---> TASKMAN QUEUE OF PRINTOUT.
+2 DO SETVARS^BWUTL5
DO SORT
DO COPYGBL
DO ^BWLABLG1
DO EXIT
+3 QUIT
