BWGRVL1.m

BWGRVL1 ; IHS/CMI/LAB - PROCESS VISIT LIST ;15-Feb-2003 21:52;PLS

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

 ;

 ;

 ;

START ;

 S (BWGRBT,BWGRBTH)=$H,BWGRJOB=$J,BWGRRCNT=0

 D XTMP^BWGRVLU("BWGRVL","WH GENERAL RETRIEVAL")

 D @BWGRTYPE,END

 Q

 ;

RP ;run with search template of patients, visit gen

 S X1=BWGRBD,X2=-1 D C^%DTC S BWGRSD=X

 S BWGRODAT=BWGRSD_".9999" F  S BWGRODAT=$O(^BWPCD("D",BWGRODAT)) Q:BWGRODAT=""!((BWGRODAT\1)>BWGRED)  D VP1

 Q

VP1 ;

 S BWGRVIEN="" F  S BWGRVIEN=$O(^BWPCD("D",BWGRODAT,BWGRVIEN)) Q:BWGRVIEN'=+BWGRVIEN  I $D(^BWPCD(BWGRVIEN,0)) S DFN=$P(^BWPCD(BWGRVIEN,0),U,2) D

 .Q:'$D(^DIBT(BWGRSEAT,1,DFN))  ;quit if patient not in search template

 .D PROC

 .Q

 Q

VV ;run by search template

 S BWGRVIEN=0 F  S BWGRVIEN=$O(^DIBT(BWGRSEAT,1,BWGRVIEN)) Q:BWGRVIEN'=+BWGRVIEN  I $D(^BWPCD(BWGRVIEN,0)) D

 .S X=$P($P(^BWPCD(BWGRVIEN,0),U),".")

 .Q:X>BWGRED

 .Q:X<BWGRBD

 .D PROC

 .Q

 Q

RS ; Run by visit date

 S X1=BWGRBD,X2=-1 D C^%DTC S BWGRSD=X

 S BWGRODAT=BWGRSD_".9999" F  S BWGRODAT=$O(^BWPCD("D",BWGRODAT)) Q:BWGRODAT=""!((BWGRODAT\1)>BWGRED)  D V1

 Q

 ;

PP ;

 S BWGRVIEN=0 F  S BWGRVIEN=$O(^BWP(BWGRVIEN)) Q:BWGRVIEN'=+BWGRVIEN  D PROC

 Q

 ;

PS ;

 S BWGRVIEN=0 F  S BWGRVIEN=$O(^DIBT(BWGRSEAT,1,BWGRVIEN)) Q:BWGRVIEN'=+BWGRVIEN  I $D(^BWP(BWGRVIEN,0)) D PROC

 Q

 ;

 ;

END ;

 S BWGRET=$H

 Q

V1 ;

 S BWGRVIEN="" F  S BWGRVIEN=$O(^BWPCD("D",BWGRODAT,BWGRVIEN)) Q:BWGRVIEN'=+BWGRVIEN  I $D(^BWPCD(BWGRVIEN,0)) D PROC

 Q

PROC ;

 K BWGRSPEC,BWGRVREC,BWGRPREC,DFN

 I BWGRPTVS="R" S BWGRVREC=^BWPCD(BWGRVIEN,0),DFN=$P(BWGRVREC,U,2)

 I BWGRPTVS="P" S DFN=BWGRVIEN,BWGRVREC=""

 S BWGRPREC=^BWP(DFN,0)

 D SCREENS

 Q:$D(BWGRSKIP)

 K BWGRSRT,BWGRPRNT S BWGRCRIT=BWGRSORT,BWGRX=0

 X:$D(^BWGRI(BWGRSORT,4)) ^BWGRI(BWGRSORT,4) I '$D(BWGRPRNT) D

 . I BWGRPTVS="R" S Y=$P($P(BWGRVREC,U),".") S BWGRPRNT=Y Q

 . S BWGRPRNT=$P(^DPT(DFN,0),U)

 .Q

 S BWGRSRT=BWGRPRNT

 D SUBPAT

 S ^XTMP("BWGRVL",BWGRJOB,BWGRBTH,"DATA HITS",BWGRSRT,BWGRVIEN)="",BWGRRCNT=BWGRRCNT+1

 Q:$D(^XTMP("BWGRVL",BWGRJOB,BWGRBTH,"PATIENTS",DFN))

 S ^XTMP("BWGRVL",BWGRJOB,BWGRBTH,"PATIENTS",DFN)="",BWGRPTCT=BWGRPTCT+1

 Q

SUBPAT ;tally # of patients by sort value on detailed/subtotal

 Q:BWGRCTYP="C"

 Q:BWGRCTYP="F"

 Q:BWGRCTYP="T"

 S:$G(BWGRSRT)="" BWGRSRT="????"

 Q:$D(^XTMP("BWGRVL",BWGRJOB,BWGRBTH,"SUB PATIENT HIT",BWGRSRT,DFN))

 S:'$D(^XTMP("BWGRVL",BWGRJOB,BWGRBTH,"SUB PAT COUNT",BWGRSRT)) ^XTMP("BWGRVL",BWGRJOB,BWGRBTH,"SUB PAT COUNT",BWGRSRT)=0

 S ^XTMP("BWGRVL",BWGRJOB,BWGRBTH,"SUB PAT COUNT",BWGRSRT)=^XTMP("BWGRVL",BWGRJOB,BWGRBTH,"SUB PAT COUNT",BWGRSRT)+1

 Q:$D(^XTMP("BWGRVL",BWGRJOB,BWGRBTH,"SUB PATIENT HIT",BWGRSRT,DFN))

 S ^XTMP("BWGRVL",BWGRJOB,BWGRBTH,"SUB PATIENT HIT",BWGRSRT,DFN)=""

 Q

SCREENS ;

 K BWGRSKIP

 S BWGRI=0 F  S BWGRI=$O(^BWGRTRPT(BWGRRPT,11,BWGRI)) Q:BWGRI'=+BWGRI!($D(BWGRSKIP))  D

 .I '$P(^BWGRI(BWGRI,0),U,8) D SINGLE Q

 .D MULT

 .Q

 Q

SINGLE ;

 K X,BWGRSPEC S X="",BWGRX=0

 X:$D(^BWGRI(BWGRI,1)) ^(1)

 I X="" S BWGRSKIP="" Q

 I '$D(BWGRSPEC),'$D(^BWGRTRPT(BWGRRPT,11,BWGRI,11,"B",X)) S BWGRSKIP="" Q

 Q

MULT ;

 K BWGRFOUN,BWGRSKIP,BWGRSPEC,X S BWGRX=0,X=""

 X:$D(^BWGRI(BWGRI,1)) ^(1)

 I $O(X(""))="" S BWGRSKIP="" Q

 I '$D(BWGRSPEC) S Y="" F  S Y=$O(X(Y)) Q:Y=""  I $D(^BWGRTRPT(BWGRRPT,11,BWGRI,11,"B",Y)) S BWGRFOUN="" Q

 I $D(BWGRSPEC),$G(X) S BWGRFOUN=1 Q

 S:'$D(BWGRFOUN) BWGRSKIP=""

 Q

XIT ;EP - CALLED FROM BWGRVL

 D EN^XBVK("BWGR"),EN^XBVK("AMQQ"),EN^XBVK("AUPN")

XIT1 ;EP

 K BWGRANS,BWGRBTH,BWGRC,BWGRCNT,BWGRCRIT,BWGRCUT,BWGRD,BWGRDISP,BWGRDONE,BWGRHIGH,BWGRI,BWGRJOB,BWGRQMAN,BWGRSEL,BWGRTEXT,BWGRVAR,BWGRSKIP,BWGRPRNT,BWGRPRNM,BWGRLINE,BWGRRCNT,BWGRSCNT,BWGRDFET,BWGRY,DFN

 K X,X1,X2,IO("Q"),%,Y,POP,DIRUT,ZTSK,ZTQUEUED,H,S,TS,M,ZTIO,DUOUT,DIR,DTOUT,V,Z,I,DIC,DIK,DIADD,DLAYGO,DA,DR,DIE,DIU,AMQQTAX,DINUM,BWGRPACK,BWGREP1,BWGREP2,D,BWGRLENG,BWGRLHDR,BWGRSAVE,AMQQND

 Q

BWGRVL1   ; IHS/CMI/LAB - PROCESS VISIT LIST ;15-Feb-2003 21:52;PLS

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

 +2       ;

 +3       ;

 +4       ;

START     ;

 +1        SET (BWGRBT,BWGRBTH)=$HOROLOG

           SET BWGRJOB=$JOB

           SET BWGRRCNT=0

 +2        DO XTMP^BWGRVLU("BWGRVL","WH GENERAL RETRIEVAL")

 +3        DO @BWGRTYPE

           DO END

 +4        QUIT 

 +5       ;

RP        ;run with search template of patients, visit gen

 +1        SET X1=BWGRBD

           SET X2=-1

           DO C^%DTC

           SET BWGRSD=X

 +2        SET BWGRODAT=BWGRSD_".9999"

           FOR 

               SET BWGRODAT=$ORDER(^BWPCD("D",BWGRODAT))

               IF BWGRODAT=""!((BWGRODAT\1)>BWGRED)

                   QUIT 

               DO VP1

 +3        QUIT 

VP1       ;

 +1        SET BWGRVIEN=""

           FOR 

               SET BWGRVIEN=$ORDER(^BWPCD("D",BWGRODAT,BWGRVIEN))

               IF BWGRVIEN'=+BWGRVIEN

                   QUIT 

               IF $DATA(^BWPCD(BWGRVIEN,0))

                   SET DFN=$PIECE(^BWPCD(BWGRVIEN,0),U,2)

                   Begin DoDot:1

 +2       ;quit if patient not in search template

                       IF '$DATA(^DIBT(BWGRSEAT,1,DFN))

                           QUIT 

 +3                    DO PROC

 +4                    QUIT 

                   End DoDot:1

 +5        QUIT 

VV        ;run by search template

 +1        SET BWGRVIEN=0

           FOR 

               SET BWGRVIEN=$ORDER(^DIBT(BWGRSEAT,1,BWGRVIEN))

               IF BWGRVIEN'=+BWGRVIEN

                   QUIT 

               IF $DATA(^BWPCD(BWGRVIEN,0))

                   Begin DoDot:1

 +2                    SET X=$PIECE($PIECE(^BWPCD(BWGRVIEN,0),U),".")

 +3                    IF X>BWGRED

                           QUIT 

 +4                    IF X<BWGRBD

                           QUIT 

 +5                    DO PROC

 +6                    QUIT 

                   End DoDot:1

 +7        QUIT 

RS        ; Run by visit date

 +1        SET X1=BWGRBD

           SET X2=-1

           DO C^%DTC

           SET BWGRSD=X

 +2        SET BWGRODAT=BWGRSD_".9999"

           FOR 

               SET BWGRODAT=$ORDER(^BWPCD("D",BWGRODAT))

               IF BWGRODAT=""!((BWGRODAT\1)>BWGRED)

                   QUIT 

               DO V1

 +3        QUIT 

 +4       ;

PP        ;

 +1        SET BWGRVIEN=0

           FOR 

               SET BWGRVIEN=$ORDER(^BWP(BWGRVIEN))

               IF BWGRVIEN'=+BWGRVIEN

                   QUIT 

               DO PROC

 +2        QUIT 

 +3       ;

PS        ;

 +1        SET BWGRVIEN=0

           FOR 

               SET BWGRVIEN=$ORDER(^DIBT(BWGRSEAT,1,BWGRVIEN))

               IF BWGRVIEN'=+BWGRVIEN

                   QUIT 

               IF $DATA(^BWP(BWGRVIEN,0))

                   DO PROC

 +2        QUIT 

 +3       ;

 +4       ;

END       ;

 +1        SET BWGRET=$HOROLOG

 +2        QUIT 

V1        ;

 +1        SET BWGRVIEN=""

           FOR 

               SET BWGRVIEN=$ORDER(^BWPCD("D",BWGRODAT,BWGRVIEN))

               IF BWGRVIEN'=+BWGRVIEN

                   QUIT 

               IF $DATA(^BWPCD(BWGRVIEN,0))

                   DO PROC

 +2        QUIT 

PROC      ;

 +1        KILL BWGRSPEC,BWGRVREC,BWGRPREC,DFN

 +2        IF BWGRPTVS="R"

               SET BWGRVREC=^BWPCD(BWGRVIEN,0)

               SET DFN=$PIECE(BWGRVREC,U,2)

 +3        IF BWGRPTVS="P"

               SET DFN=BWGRVIEN

               SET BWGRVREC=""

 +4        SET BWGRPREC=^BWP(DFN,0)

 +5        DO SCREENS

 +6        IF $DATA(BWGRSKIP)

               QUIT 

 +7        KILL BWGRSRT,BWGRPRNT

           SET BWGRCRIT=BWGRSORT

           SET BWGRX=0

 +8        IF $DATA(^BWGRI(BWGRSORT,4))

               XECUTE ^BWGRI(BWGRSORT,4)

           IF '$DATA(BWGRPRNT)

               Begin DoDot:1

 +9                IF BWGRPTVS="R"

                       SET Y=$PIECE($PIECE(BWGRVREC,U),".")

                       SET BWGRPRNT=Y

                       QUIT 

 +10               SET BWGRPRNT=$PIECE(^DPT(DFN,0),U)

 +11               QUIT 

               End DoDot:1

 +12       SET BWGRSRT=BWGRPRNT

 +13       DO SUBPAT

 +14       SET ^XTMP("BWGRVL",BWGRJOB,BWGRBTH,"DATA HITS",BWGRSRT,BWGRVIEN)=""

           SET BWGRRCNT=BWGRRCNT+1

 +15       IF $DATA(^XTMP("BWGRVL",BWGRJOB,BWGRBTH,"PATIENTS",DFN))

               QUIT 

 +16       SET ^XTMP("BWGRVL",BWGRJOB,BWGRBTH,"PATIENTS",DFN)=""

           SET BWGRPTCT=BWGRPTCT+1

 +17       QUIT 

SUBPAT    ;tally # of patients by sort value on detailed/subtotal

 +1        IF BWGRCTYP="C"

               QUIT 

 +2        IF BWGRCTYP="F"

               QUIT 

 +3        IF BWGRCTYP="T"

               QUIT 

 +4        IF $GET(BWGRSRT)=""

               SET BWGRSRT="????"

 +5        IF $DATA(^XTMP("BWGRVL",BWGRJOB,BWGRBTH,"SUB PATIENT HIT",BWGRSRT,DFN))

               QUIT 

 +6        IF '$DATA(^XTMP("BWGRVL",BWGRJOB,BWGRBTH,"SUB PAT COUNT",BWGRSRT))

               SET ^XTMP("BWGRVL",BWGRJOB,BWGRBTH,"SUB PAT COUNT",BWGRSRT)=0

 +7        SET ^XTMP("BWGRVL",BWGRJOB,BWGRBTH,"SUB PAT COUNT",BWGRSRT)=^XTMP("BWGRVL",BWGRJOB,BWGRBTH,"SUB PAT COUNT",BWGRSRT)+1

 +8        IF $DATA(^XTMP("BWGRVL",BWGRJOB,BWGRBTH,"SUB PATIENT HIT",BWGRSRT,DFN))

               QUIT 

 +9        SET ^XTMP("BWGRVL",BWGRJOB,BWGRBTH,"SUB PATIENT HIT",BWGRSRT,DFN)=""

 +10       QUIT 

SCREENS   ;

 +1        KILL BWGRSKIP

 +2        SET BWGRI=0

           FOR 

               SET BWGRI=$ORDER(^BWGRTRPT(BWGRRPT,11,BWGRI))

               IF BWGRI'=+BWGRI!($DATA(BWGRSKIP))

                   QUIT 

               Begin DoDot:1

 +3                IF '$PIECE(^BWGRI(BWGRI,0),U,8)

                       DO SINGLE

                       QUIT 

 +4                DO MULT

 +5                QUIT 

               End DoDot:1

 +6        QUIT 

SINGLE    ;

 +1        KILL X,BWGRSPEC

           SET X=""

           SET BWGRX=0

 +2        IF $DATA(^BWGRI(BWGRI,1))

               XECUTE ^(1)

 +3        IF X=""

               SET BWGRSKIP=""

               QUIT 

 +4        IF '$DATA(BWGRSPEC)

               IF '$DATA(^BWGRTRPT(BWGRRPT,11,BWGRI,11,"B",X))

                   SET BWGRSKIP=""

                   QUIT 

 +5        QUIT 

MULT      ;

 +1        KILL BWGRFOUN,BWGRSKIP,BWGRSPEC,X

           SET BWGRX=0

           SET X=""

 +2        IF $DATA(^BWGRI(BWGRI,1))

               XECUTE ^(1)

 +3        IF $ORDER(X(""))=""

               SET BWGRSKIP=""

               QUIT 

 +4        IF '$DATA(BWGRSPEC)

               SET Y=""

               FOR 

                   SET Y=$ORDER(X(Y))

                   IF Y=""

                       QUIT 

                   IF $DATA(^BWGRTRPT(BWGRRPT,11,BWGRI,11,"B",Y))

                       SET BWGRFOUN=""

                       QUIT 

 +5        IF $DATA(BWGRSPEC)

               IF $GET(X)

                   SET BWGRFOUN=1

                   QUIT 

 +6        IF '$DATA(BWGRFOUN)

               SET BWGRSKIP=""

 +7        QUIT 

XIT       ;EP - CALLED FROM BWGRVL

 +1        DO EN^XBVK("BWGR")

           DO EN^XBVK("AMQQ")

           DO EN^XBVK("AUPN")

XIT1      ;EP

 +1        KILL BWGRANS,BWGRBTH,BWGRC,BWGRCNT,BWGRCRIT,BWGRCUT,BWGRD,BWGRDISP,BWGRDONE,BWGRHIGH,BWGRI,BWGRJOB,BWGRQMAN,BWGRSEL,BWGRTEXT,BWGRVAR,BWGRSKIP,BWGRPRNT,BWGRPRNM,BWGRLINE,BWGRRCNT,BWGRSCNT,BWGRDFET,BWGRY,DFN

 +2        KILL X,X1,X2,IO("Q"),%,Y,POP,DIRUT,ZTSK,ZTQUEUED,H,S,TS,M,ZTIO,DUOUT,DIR,DTOUT,V,Z,I,DIC,DIK,DIADD,DLAYGO,DA,DR,DIE,DIU,AMQQTAX,DINUM,BWGRPACK,BWGREP1,BWGREP2,D,BWGRLENG,BWGRLHDR,BWGRSAVE,AMQQND

 +3        QUIT