BDGVHF.m

BDGVHF ; IHS/ANMC/LJF - CREATE VHOSP IF MISSING ;  [ 05/31/2002  4:22 PM ]

 ;;5.3;PIMS;**1005**;MAY 28, 2004

 ;IHS/OIT/LJF 04/26/2006 PATCH 1005 fixed date calls

 ;

 ;

 NEW BDGBD,BDGED

 ;IHS/OIT/LJF 04/26/2006 PATCH 1005

 ;S BDGBD=$$READ^BDGF("DO^::EQ","Beginning Discharge Date") Q:BDGBD<1

 ;S BDGED=$$READ^BDGF("DO^"_BDGBD_":"_DT_":EQ","Ending Discharge Date")

 S BDGBD=$$READ^BDGF("DO^::E","Beginning Discharge Date") Q:BDGBD<1

 S BDGED=$$READ^BDGF("DO^"_BDGBD_":"_DT_":E","Ending Discharge Date")

 ;

 Q:BDGED<1

 ;

 D ZIS^BDGF("PQ","LOOP^BDGVHF","FIX MISSING VHOSP","BDGBD;BDGED")

 Q

 ;

 ;

LOOP ;EP; loop thru discharges to check for missing vhosps

 NEW DATE,DGEND,DSC,ADM,VST

 U IO D INIT,HED

 ;

 S DATE=BDGBD-.0001,DGEND=BDGED+.2400

 F  S DATE=$O(^DGPM("ATT3",DATE)) Q:DATE=""!(DATE>DGEND)  D

 . S DSC=0

 . F  S DSC=$O(^DGPM("ATT3",DATE,DSC)) Q:DSC=""  D

 .. S ADM=$$GET1^DIQ(405,DSC,.14,"I") Q:'ADM   ;corresponding admission

 .. Q:'$G(^DGPM(ADM,0))                        ;bad pointer

 .. ;

 .. ;IHS/ANMC/LJF 5/29/2002 fixed setting of VST and added check for

 .. ;           deleted visit (per LJF3) 

 .. ;S VST=$P($G(^DGPM(ADM,"IHS")),U)

 .. ;I $O(^AUPNVINP("AD",+VST,0)) Q              ;entry okay

 .. S VST=$P($G(^DGPM(ADM,0)),U,27)

 .. I $O(^AUPNVINP("AD",+VST,0)),$P($G(^AUPNVSIT(+VST,0)),U,11)'=1 Q

 .. ;IHS/ANMC/LJF 5/29/2002 end of mods

 .. NEW DFN,DGPMA,DGPMCA

 .. S DFN=$$GET1^DIQ(405,DSC,.03,"I")     ;patient ien

 .. S DGPMA=$G(^DGPM(DSC,0))              ;discharge node

 .. S DGPMCA=ADM

 .. W !,$$GET1^DIQ(405,DSC,.01),?20,$$GET1^DIQ(2,DFN,.01)

 .. D ADDVH^BDGPCCL

 ;

 I $E(IOST,1,2)="C-" D PAUSE^BDGF

 D ^%ZISC

 Q

 ;

 ;

INIT ; initialize variables

 S DGPG=0,DGDUZ=$P(^VA(200,DUZ,0),U,2),DGSITE=$P(^DIC(4,DUZ(2),0),U)

 S DGLIN=$$REPEAT^XLFSTR("=",80),DGLIN2=$$REPEAT^XLFSTR("-",80)

 S DGQ=""

 Q

 ;

HED ; -- heading

 I (DGPG>0)!(IOST["C-") W @IOF

 W !,DGLIN S DGPG=DGPG+1

 W !?11,"*****Confidential Patient Data Covered by Privacy Act*****"

 W !,DGDUZ,?80-$L(DGSITE)/2,DGSITE S DGTY="FIX MISSING V HOSP ENTRIES"

 W !,$$TIME^BDGF($$NOW^XLFDT),?80-$L(DGTY)/2,DGTY,?70,"Page: ",DGPG

 S Y=DT X ^DD("DD") W !,Y

 W !,DGLIN2,!

 Q

 ;

BDGVHF    ; IHS/ANMC/LJF - CREATE VHOSP IF MISSING ;  [ 05/31/2002  4:22 PM ]

 +1       ;;5.3;PIMS;**1005**;MAY 28, 2004

 +2       ;IHS/OIT/LJF 04/26/2006 PATCH 1005 fixed date calls

 +3       ;

 +4       ;

 +5        NEW BDGBD,BDGED

 +6       ;IHS/OIT/LJF 04/26/2006 PATCH 1005

 +7       ;S BDGBD=$$READ^BDGF("DO^::EQ","Beginning Discharge Date") Q:BDGBD<1

 +8       ;S BDGED=$$READ^BDGF("DO^"_BDGBD_":"_DT_":EQ","Ending Discharge Date")

 +9        SET BDGBD=$$READ^BDGF("DO^::E","Beginning Discharge Date")

           IF BDGBD<1

               QUIT 

 +10       SET BDGED=$$READ^BDGF("DO^"_BDGBD_":"_DT_":E","Ending Discharge Date")

 +11      ;

 +12       IF BDGED<1

               QUIT 

 +13      ;

 +14       DO ZIS^BDGF("PQ","LOOP^BDGVHF","FIX MISSING VHOSP","BDGBD;BDGED")

 +15       QUIT 

 +16      ;

 +17      ;

LOOP      ;EP; loop thru discharges to check for missing vhosps

 +1        NEW DATE,DGEND,DSC,ADM,VST

 +2        USE IO

           DO INIT

           DO HED

 +3       ;

 +4        SET DATE=BDGBD-.0001

           SET DGEND=BDGED+.2400

 +5        FOR 

               SET DATE=$ORDER(^DGPM("ATT3",DATE))

               IF DATE=""!(DATE>DGEND)

                   QUIT 

               Begin DoDot:1

 +6                SET DSC=0

 +7                FOR 

                       SET DSC=$ORDER(^DGPM("ATT3",DATE,DSC))

                       IF DSC=""

                           QUIT 

                       Begin DoDot:2

 +8       ;corresponding admission

                           SET ADM=$$GET1^DIQ(405,DSC,.14,"I")

                           IF 'ADM

                               QUIT 

 +9       ;bad pointer

                           IF '$GET(^DGPM(ADM,0))

                               QUIT 

 +10      ;

 +11      ;IHS/ANMC/LJF 5/29/2002 fixed setting of VST and added check for

 +12      ;           deleted visit (per LJF3) 

 +13      ;S VST=$P($G(^DGPM(ADM,"IHS")),U)

 +14      ;I $O(^AUPNVINP("AD",+VST,0)) Q              ;entry okay

 +15                       SET VST=$PIECE($GET(^DGPM(ADM,0)),U,27)

 +16                       IF $ORDER(^AUPNVINP("AD",+VST,0))

                               IF $PIECE($GET(^AUPNVSIT(+VST,0)),U,11)'=1

                                   QUIT 

 +17      ;IHS/ANMC/LJF 5/29/2002 end of mods

 +18                       NEW DFN,DGPMA,DGPMCA

 +19      ;patient ien

                           SET DFN=$$GET1^DIQ(405,DSC,.03,"I")

 +20      ;discharge node

                           SET DGPMA=$GET(^DGPM(DSC,0))

 +21                       SET DGPMCA=ADM

 +22                       WRITE !,$$GET1^DIQ(405,DSC,.01),?20,$$GET1^DIQ(2,DFN,.01)

 +23                       DO ADDVH^BDGPCCL

                       End DoDot:2

               End DoDot:1

 +24      ;

 +25       IF $EXTRACT(IOST,1,2)="C-"

               DO PAUSE^BDGF

 +26       DO ^%ZISC

 +27       QUIT 

 +28      ;

 +29      ;

INIT      ; initialize variables

 +1        SET DGPG=0

           SET DGDUZ=$PIECE(^VA(200,DUZ,0),U,2)

           SET DGSITE=$PIECE(^DIC(4,DUZ(2),0),U)

 +2        SET DGLIN=$$REPEAT^XLFSTR("=",80)

           SET DGLIN2=$$REPEAT^XLFSTR("-",80)

 +3        SET DGQ=""

 +4        QUIT 

 +5       ;

HED       ; -- heading

 +1        IF (DGPG>0)!(IOST["C-")

               WRITE @IOF

 +2        WRITE !,DGLIN

           SET DGPG=DGPG+1

 +3        WRITE !?11,"*****Confidential Patient Data Covered by Privacy Act*****"

 +4        WRITE !,DGDUZ,?80-$LENGTH(DGSITE)/2,DGSITE

           SET DGTY="FIX MISSING V HOSP ENTRIES"

 +5        WRITE !,$$TIME^BDGF($$NOW^XLFDT),?80-$LENGTH(DGTY)/2,DGTY,?70,"Page: ",DGPG

 +6        SET Y=DT

           XECUTE ^DD("DD")

           WRITE !,Y

 +7        WRITE !,DGLIN2,!

 +8        QUIT 

 +9       ;