BWLABLG.m

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