BWBRPCD.m

BWBRPCD ;IHS/ANMC/MWR - BROWSE PROCEDURES;27-Feb-2003 22:26;PLS

 ;;2.0;WOMEN'S HEALTH;**8**;MAY 16, 1996

 ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *

 ;;  CALLED BY OPTION: "BW BROWSE PROCEDURES" TO BROWSE AND EDIT

 ;;  PROCEDURES.

 ;

 ;---> VARIABLES:

 ;---> BWA:   1=ALL PATIENTS, 0=ONE PATIENT

 ;---> BWDFN: DFN OF SELECTED PATIENT

 ;---> DATES: BWBEGDT=BEGINNING DATE, BWENDDT=ENDING DATE

 ;---> BWD:   1=BOTH ABNORMAL AND NORMAL, 0=NORMAL ONLY

 ;---> SORT SEQUENCE IN BWC:  1=DATE, PATIENT, PRIORITY

 ;--->                        2=PATIENT, DATE, PRIORITY

 ;--->                        3=PRIORITY, DATE, PATIENT

 ;---> USE NODES 1 & 2 IN ^TMP GLOBAL

 ;

 D SETVARS^BWUTL5 S BWPOP=0

 D ^BWBRPCD2 G:BWPOP EXIT

 D SORT

 D COPYGBL

 ;---> NEXT LINE: PASS TITLE, HEADER (IN ^BWUTL7), AND CODE TO

 ;---> EXECUTE BY DIR AT BOTTOM OF SCREEN.

 D DISPLAY^BWBRPCD1(BWTITLE,BWHEADER,BWCODE)

 ;

EXIT ;EP

 D KILLALL^BWUTL8

 Q

 ;

 ;

SORT ;EP

 ;---> SORT AND STORE ARRAY IN ^TMP("BW",$J

 N BWPROC

 K ^TMP("BW",$J)

 ;---> BWBEGDT1=ONE SECOND BEFORE BEGIN DATE.

 ;---> BWENDDT1=THE LAST SECOND OF END DATE.

 S BWBEGDT1=BWBEGDT-.0001,BWENDDT1=BWENDDT+.9999

 ;

 ;***********************

 ;---> BWA=1 ALL PATIENTS

 I BWA D  Q

 .;---> BY DATE GET EITHER ALL OR ABNORMAL ONLY.

 .;---> ("INSUFFICIENT TISSUE" IS INCLUDED IN ABNML XREF.)

 .S BWXREF=$S(BWD:"D",1:"ABNML")

 .S BWDATE=BWBEGDT1

 .F  S BWDATE=$O(^BWPCD(BWXREF,BWDATE)) Q:'BWDATE!(BWDATE>BWENDDT1)  D

 ..S BWIEN=0

 ..F  S BWIEN=$O(^BWPCD(BWXREF,BWDATE,BWIEN)) Q:'BWIEN  D

 ...S Y=^BWPCD(BWIEN,0),BWDFN=$P(Y,U,2),BWPROC=+$P(Y,U,4)

 ...;---> QUIT IF THIS PROCEDURE HAS A RESULT OF "ERROR/DISREGARD".

 ...Q:$P(Y,U,5)=8

 ...;---> QUIT IF NOT SELECTING FOR ALL PROCEDURES AND IF THIS IS

 ...;---> NOT ONE OF THE SELECTED PROCEDURES.

 ...I '$D(BWARR("ALL"))  Q:'$D(BWARR(BWPROC))

 ...;---> QUIT IF NOT "ALL PROCEDURES" AND THIS ENTRY IS "CLOSED".

 ...Q:BWB'="a"&($P(Y,U,14)="c")

 ...;---> QUIT IF SELECTING FOR ONE CASE MANAGER AND THIS DOESN'T MATCH.

 ...I 'BWE Q:$P(^BWP(BWDFN,0),U,10)'=BWCMGR

 ...;---> QUIT IF LISTING "DELINQUENT" AND THIS PROCDURE IS NOT DELINQ.

 ...I BWB="d" Q:$P(Y,U,13)>DT!($P(Y,U,13)="")

 ...;---> QUIT IF LISTING "NEW" AND THIS PROCDURE IS NOT NEW.

 ...Q:BWB="n"&($P(Y,U,14)'="n")

 ...D STORE(BWC,BWIEN,Y)

 ;

 ;**********************

 ;---> BWA=0 ONE PATIENT

 S BWIEN=0

 F  S BWIEN=$O(^BWPCD("C",BWDFN,BWIEN)) Q:'BWIEN  D

 .;---> SET Y=THE ZERO NODE FOR THIS PROCEDURE.

 .S Y=^BWPCD(BWIEN,0)

 .;---> QUIT IF THIS PROCEDURE HAS A RESULT OF "ERROR/DISREGARD".

 .Q:$P(Y,U,5)=8

 .;---> QUIT IF NOT WITHIN DATE RANGE.

 .S BWDATE=$P(Y,U,12)

 .Q:BWDATE'>BWBEGDT1!(BWDATE>BWENDDT1)

 .;---> QUIT IF SELECTING FOR "ABNORMAL" ONLY AND THIS PROCEDURE

 .;---> "NORMAL". ("INSUFF TISSUE" AND "UNSAT EXAM" WILL BE "ABNORMAL".)

 .Q:'BWD&('$$NORMAL^BWUTL4($P(Y,U,5)))

 .;---> QUIT IF "DELINQUENT" OR "OPEN" ONLY AND THIS ENTRY IS "CLOSED".

 .Q:BWB'="a"&($P(Y,U,14)="c")

 .;---> QUIT IF LISTING "DELINQUENT" AND THIS PROCDURE IS NOT DELINQ.

 .I BWB="d" Q:$P(Y,U,13)>DT!($P(Y,U,13)="")

 .Q:BWB="n"&($P(Y,U,14)'="n")

 .D STORE(BWC,BWIEN,Y)

 Q

 ;

STORE(BWC,BWIEN,Y) ;EP

 ;---> CALLED TO STORE PROCEDURES IN ^TMP FOR BROWSING.

 ;---> BWC=LIST ORDER, BWIEN=IEN OR PROCEDURE, Y=ZERO NODE OF PROCEDURE.

 S BWDFN=$P(Y,U,2),BWDATE=$P(Y,U,12)                   ;---> DFN, DATE

 S BWCHRT=$$HRCN^BWUTL1(BWDFN)                         ;---> CHART#

 S BWNAME=$$NAME^BWUTL1(BWDFN)                         ;---> NAME

 S BWACC=$P(Y,U)                                       ;---> ACCESSION#

 S BWSTAT=$E($$STATUS^BWUTL4)                          ;---> STATUS

 S BWDIAG=$$DIAG^BWUTL4($P(Y,U,5))                     ;---> RESULT/DIAG

 S X=$P(Y,U,5),BWPRIO=$$PRIOR^BWUTL4 K X               ;---> PRIORITY

 ;

 S X=BWCHRT_U_BWNAME_U_BWDATE_U_BWACC_U_BWDIAG_U_BWPRIO_U_BWSTAT_U_BWIEN

 I BWC=1 S ^TMP("BW",$J,1,BWDATE,BWNAME,BWPRIO,BWIEN)=X Q

 I BWC=2 S ^TMP("BW",$J,1,BWNAME,BWDATE,BWPRIO,BWIEN)=X Q

 I BWC=3 S ^TMP("BW",$J,1,BWPRIO,BWDATE,BWNAME,BWIEN)=X

 Q

 ;

COPYGBL ;EP

 ;---> CALLED TO FLATTEN THE ^TMP ARRAY OF PROCEDURES FOR BROWSING.

 ;---> 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 Q=0

 ...F  S Q=$O(^TMP("BW",$J,1,N,M,P,Q)) Q:Q=""  D

 ....S I=I+1,^TMP("BW",$J,2,I)=^TMP("BW",$J,1,N,M,P,Q)

 Q

 ;

DEQUEUE ;EP

 ;---> FOR TASKMAN QUEUE OF PRINTOUT.

 D SETVARS^BWUTL5,SORT,COPYGBL

 D DISPLAY^BWBRPCD1(BWTITLE,BWHEADER,BWCODE)

 D EXIT

 Q

BWBRPCD   ;IHS/ANMC/MWR - BROWSE PROCEDURES;27-Feb-2003 22:26;PLS

 +1       ;;2.0;WOMEN'S HEALTH;**8**;MAY 16, 1996

 +2       ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *

 +3       ;;  CALLED BY OPTION: "BW BROWSE PROCEDURES" TO BROWSE AND EDIT

 +4       ;;  PROCEDURES.

 +5       ;

 +6       ;---> VARIABLES:

 +7       ;---> BWA:   1=ALL PATIENTS, 0=ONE PATIENT

 +8       ;---> BWDFN: DFN OF SELECTED PATIENT

 +9       ;---> DATES: BWBEGDT=BEGINNING DATE, BWENDDT=ENDING DATE

 +10      ;---> BWD:   1=BOTH ABNORMAL AND NORMAL, 0=NORMAL ONLY

 +11      ;---> SORT SEQUENCE IN BWC:  1=DATE, PATIENT, PRIORITY

 +12      ;--->                        2=PATIENT, DATE, PRIORITY

 +13      ;--->                        3=PRIORITY, DATE, PATIENT

 +14      ;---> USE NODES 1 & 2 IN ^TMP GLOBAL

 +15      ;

 +16       DO SETVARS^BWUTL5

           SET BWPOP=0

 +17       DO ^BWBRPCD2

           IF BWPOP

               GOTO EXIT

 +18       DO SORT

 +19       DO COPYGBL

 +20      ;---> NEXT LINE: PASS TITLE, HEADER (IN ^BWUTL7), AND CODE TO

 +21      ;---> EXECUTE BY DIR AT BOTTOM OF SCREEN.

 +22       DO DISPLAY^BWBRPCD1(BWTITLE,BWHEADER,BWCODE)

 +23      ;

EXIT      ;EP

 +1        DO KILLALL^BWUTL8

 +2        QUIT 

 +3       ;

 +4       ;

SORT      ;EP

 +1       ;---> SORT AND STORE ARRAY IN ^TMP("BW",$J

 +2        NEW BWPROC

 +3        KILL ^TMP("BW",$JOB)

 +4       ;---> BWBEGDT1=ONE SECOND BEFORE BEGIN DATE.

 +5       ;---> BWENDDT1=THE LAST SECOND OF END DATE.

 +6        SET BWBEGDT1=BWBEGDT-.0001

           SET BWENDDT1=BWENDDT+.9999

 +7       ;

 +8       ;***********************

 +9       ;---> BWA=1 ALL PATIENTS

 +10       IF BWA

               Begin DoDot:1

 +11      ;---> BY DATE GET EITHER ALL OR ABNORMAL ONLY.

 +12      ;---> ("INSUFFICIENT TISSUE" IS INCLUDED IN ABNML XREF.)

 +13               SET BWXREF=$SELECT(BWD:"D",1:"ABNML")

 +14               SET BWDATE=BWBEGDT1

 +15               FOR 

                       SET BWDATE=$ORDER(^BWPCD(BWXREF,BWDATE))

                       IF 'BWDATE!(BWDATE>BWENDDT1)

                           QUIT 

                       Begin DoDot:2

 +16                       SET BWIEN=0

 +17                       FOR 

                               SET BWIEN=$ORDER(^BWPCD(BWXREF,BWDATE,BWIEN))

                               IF 'BWIEN

                                   QUIT 

                               Begin DoDot:3

 +18                               SET Y=^BWPCD(BWIEN,0)

                                   SET BWDFN=$PIECE(Y,U,2)

                                   SET BWPROC=+$PIECE(Y,U,4)

 +19      ;---> QUIT IF THIS PROCEDURE HAS A RESULT OF "ERROR/DISREGARD".

 +20                               IF $PIECE(Y,U,5)=8

                                       QUIT 

 +21      ;---> QUIT IF NOT SELECTING FOR ALL PROCEDURES AND IF THIS IS

 +22      ;---> NOT ONE OF THE SELECTED PROCEDURES.

 +23                               IF '$DATA(BWARR("ALL"))

                                       IF '$DATA(BWARR(BWPROC))

                                           QUIT 

 +24      ;---> QUIT IF NOT "ALL PROCEDURES" AND THIS ENTRY IS "CLOSED".

 +25                               IF BWB'="a"&($PIECE(Y,U,14)="c")

                                       QUIT 

 +26      ;---> QUIT IF SELECTING FOR ONE CASE MANAGER AND THIS DOESN'T MATCH.

 +27                               IF 'BWE

                                       IF $PIECE(^BWP(BWDFN,0),U,10)'=BWCMGR

                                           QUIT 

 +28      ;---> QUIT IF LISTING "DELINQUENT" AND THIS PROCDURE IS NOT DELINQ.

 +29                               IF BWB="d"

                                       IF $PIECE(Y,U,13)>DT!($PIECE(Y,U,13)="")

                                           QUIT 

 +30      ;---> QUIT IF LISTING "NEW" AND THIS PROCDURE IS NOT NEW.

 +31                               IF BWB="n"&($PIECE(Y,U,14)'="n")

                                       QUIT 

 +32                               DO STORE(BWC,BWIEN,Y)

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

               QUIT 

 +33      ;

 +34      ;**********************

 +35      ;---> BWA=0 ONE PATIENT

 +36       SET BWIEN=0

 +37       FOR 

               SET BWIEN=$ORDER(^BWPCD("C",BWDFN,BWIEN))

               IF 'BWIEN

                   QUIT 

               Begin DoDot:1

 +38      ;---> SET Y=THE ZERO NODE FOR THIS PROCEDURE.

 +39               SET Y=^BWPCD(BWIEN,0)

 +40      ;---> QUIT IF THIS PROCEDURE HAS A RESULT OF "ERROR/DISREGARD".

 +41               IF $PIECE(Y,U,5)=8

                       QUIT 

 +42      ;---> QUIT IF NOT WITHIN DATE RANGE.

 +43               SET BWDATE=$PIECE(Y,U,12)

 +44               IF BWDATE'>BWBEGDT1!(BWDATE>BWENDDT1)

                       QUIT 

 +45      ;---> QUIT IF SELECTING FOR "ABNORMAL" ONLY AND THIS PROCEDURE

 +46      ;---> "NORMAL". ("INSUFF TISSUE" AND "UNSAT EXAM" WILL BE "ABNORMAL".)

 +47               IF 'BWD&('$$NORMAL^BWUTL4($PIECE(Y,U,5)))

                       QUIT 

 +48      ;---> QUIT IF "DELINQUENT" OR "OPEN" ONLY AND THIS ENTRY IS "CLOSED".

 +49               IF BWB'="a"&($PIECE(Y,U,14)="c")

                       QUIT 

 +50      ;---> QUIT IF LISTING "DELINQUENT" AND THIS PROCDURE IS NOT DELINQ.

 +51               IF BWB="d"

                       IF $PIECE(Y,U,13)>DT!($PIECE(Y,U,13)="")

                           QUIT 

 +52               IF BWB="n"&($PIECE(Y,U,14)'="n")

                       QUIT 

 +53               DO STORE(BWC,BWIEN,Y)

               End DoDot:1

 +54       QUIT 

 +55      ;

STORE(BWC,BWIEN,Y) ;EP

 +1       ;---> CALLED TO STORE PROCEDURES IN ^TMP FOR BROWSING.

 +2       ;---> BWC=LIST ORDER, BWIEN=IEN OR PROCEDURE, Y=ZERO NODE OF PROCEDURE.

 +3       ;---> DFN, DATE

           SET BWDFN=$PIECE(Y,U,2)

           SET BWDATE=$PIECE(Y,U,12)

 +4       ;---> CHART#

           SET BWCHRT=$$HRCN^BWUTL1(BWDFN)

 +5       ;---> NAME

           SET BWNAME=$$NAME^BWUTL1(BWDFN)

 +6       ;---> ACCESSION#

           SET BWACC=$PIECE(Y,U)

 +7       ;---> STATUS

           SET BWSTAT=$EXTRACT($$STATUS^BWUTL4)

 +8       ;---> RESULT/DIAG

           SET BWDIAG=$$DIAG^BWUTL4($PIECE(Y,U,5))

 +9       ;---> PRIORITY

           SET X=$PIECE(Y,U,5)

           SET BWPRIO=$$PRIOR^BWUTL4

           KILL X

 +10      ;

 +11       SET X=BWCHRT_U_BWNAME_U_BWDATE_U_BWACC_U_BWDIAG_U_BWPRIO_U_BWSTAT_U_BWIEN

 +12       IF BWC=1

               SET ^TMP("BW",$JOB,1,BWDATE,BWNAME,BWPRIO,BWIEN)=X

               QUIT 

 +13       IF BWC=2

               SET ^TMP("BW",$JOB,1,BWNAME,BWDATE,BWPRIO,BWIEN)=X

               QUIT 

 +14       IF BWC=3

               SET ^TMP("BW",$JOB,1,BWPRIO,BWDATE,BWNAME,BWIEN)=X

 +15       QUIT 

 +16      ;

COPYGBL   ;EP

 +1       ;---> CALLED TO FLATTEN THE ^TMP ARRAY OF PROCEDURES FOR BROWSING.

 +2       ;---> COPY ^TMP("BW",$J,1 TO ^TMP("BW",$J,2 TO MAKE IT FLAT.

 +3        NEW I,M,N,P,Q

 +4        SET N=0

           SET I=0

 +5        FOR 

               SET N=$ORDER(^TMP("BW",$JOB,1,N))

               IF N=""

                   QUIT 

               Begin DoDot:1

 +6                SET M=0

 +7                FOR 

                       SET M=$ORDER(^TMP("BW",$JOB,1,N,M))

                       IF M=""

                           QUIT 

                       Begin DoDot:2

 +8                        SET P=0

 +9                        FOR 

                               SET P=$ORDER(^TMP("BW",$JOB,1,N,M,P))

                               IF P=""

                                   QUIT 

                               Begin DoDot:3

 +10                               SET Q=0

 +11                               FOR 

                                       SET Q=$ORDER(^TMP("BW",$JOB,1,N,M,P,Q))

                                       IF Q=""

                                           QUIT 

                                       Begin DoDot:4

 +12                                       SET I=I+1

                                           SET ^TMP("BW",$JOB,2,I)=^TMP("BW",$JOB,1,N,M,P,Q)

                                       End DoDot:4

                               End DoDot:3

                       End DoDot:2

               End DoDot:1

 +13       QUIT 

 +14      ;

DEQUEUE   ;EP

 +1       ;---> FOR TASKMAN QUEUE OF PRINTOUT.

 +2        DO SETVARS^BWUTL5

           DO SORT

           DO COPYGBL

 +3        DO DISPLAY^BWBRPCD1(BWTITLE,BWHEADER,BWCODE)

 +4        DO EXIT

 +5        QUIT