ADGVHF.m

ADGVHF ; IHS/ADC/PDW/ENM - CREATE VHOSP IF MISSING ; [ 03/25/1999  11:48 AM ]

 ;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999

 ;

 ;

 ; -- select date range

DATE S %DT="AEQ",%DT("A")="Beginning date: ",X="" D ^%DT

 G END:Y=-1 S DGBDT=Y

DATE2 S %DT("A")="Ending date: ",X="" D ^%DT G DATE:Y=-1 S DGEDT=Y

 I DGEDT<DGBDT W *7,!!?5,"Ending date MUST NOT be before beginning date",! G DATE2

 I DGEDT'<DT S X1=DT,X2=-1 D C^%DTC S DGEDT=X

 ;

 ; -- select print device

 S %ZIS="PQ" D ^%ZIS G END:POP,QUE:$D(IO("Q")) U IO G LOOP

QUE K IO("Q") S ZTRTN="LOOP^ADGVHF" S ZTDESC="FIX MISSING VHOSP"

 F I="DGBDT","DGEDT" S ZTSAVE(I)=""

 D ^%ZTLOAD D ^%ZISC K ZTSK

 ;

END K Y,DGBDT,DGEDT D HOME^%ZIS Q

 ;

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

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

 S DGLIN="",$P(DGLIN,"=",80)="",DGLIN2="",$P(DGLIN2,"-",80)=""

 S DGQ="" D HED

 ;

 S DGDT=DGBDT-.0001,DGEND=DGEDT+.2400

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

 . S DGDSC=0

 . F  S DGDSC=$O(^DGPM("ATT3",DGDT,DGDSC)) Q:DGDSC=""!(DGQ=U)  D

 .. S DGD=$G(^DGPM(DGDSC,0)) Q:DGD=""

 .. S DGADM=$P(^DGPM(DGDSC,0),U,14) ;corresponding adm

 .. S DGA=$G(^DGPM(DGADM,0)) Q:DGA=""

 .. S DGV=$P($G(^DGPM(DGADM,"IHS")),U)

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

 .. D ADD

 ;

 K DFN,DGD,DGDUZ,DGLIN,DGLIN2,DGPG,DGSITE,DGTY

 K DGQ,DGDT,DGBDT,DGEDT,DGEND,DGDSC,DGADM,DGA,DGV D ^%ZISC

 Q

 ;

 ;

ADD ; -- SUBRTN to set variables to call apcdalvr

 D ^APCDEIN S DFN=$P(DGA,U,3)

 I DGV="" D

 . NEW DGPMA,DGPMDA,DGPMCA

 . S DGPMA=DGA,(DGPMDA,DGPMCA)=DGADM D APCDALV^ADGCALLS

 . S DGV=$P($G(^DGPM(DGADM,"IHS")),U)

 S APCDALVR("APCDPAT")=DFN

 S APCDALVR("APCDTDT")="`"_$P(DGD,U,4)

 S APCDALVR("APCDATMP")="[APCDALVR 9000010.02 (ADD)]"

 S:$P(DGA,U,18)=10 APCDALVR("APCDTTT")=$$TFAC

 S APCDALVR("APCDLOOK")=$E(+DGD,1,12)

 S APCDALVR("APCDTDCS")="`"_$$DSRV

 S APCDALVR("APCDTADS")="`"_$P(^DGPM($O(^DGPM("APHY",DGADM,0)),0),U,9)

 S APCDALVR("APCDTAT")="`"_$P(DGA,U,4)

 S APCDALVR("APCDVSIT")=DGV

 D ^APCDALVR

 I $D(APCDALVR("APCDAFLG")) D MSG(2),NEWPG,KILL Q

 D MSG(1),KILL Q

 ;

KILL ; -- kill apcd variables

 D APCDEKL^ADGCALLS Q

 ;

TFAC() ; -- transfer facility

 NEW X S X=$P(DGD,U,5)

 Q $S(X["DIC(4":"VA/IHS.`",1:"VENDOR.`")_+X

 ;

DSRV() ; -- discharge service

 NEW X,Y

 S Y=9999999.9999999-$G(^DGPM(+$P(^DGPM(DGADM,0),U,17),0)) Q:'Y 0

 S X=$O(^DGPM("ATID6",+DFN,+$O(^DGPM("ATID6",+DFN,Y)),0))

 Q $P($G(^DGPM(+X,0)),U,9)

 ;

NEWPG ; -- end of page control

 I IOST'["C-" D HED Q

 K DIR S DIR(0)="E" D ^DIR S DGQ=X

 I DGQ'=U D HED

 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 ! D TIME^ADGUTIL W ?80-$L(DGTY)/2,DGTY,?70,"Page: ",DGPG

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

 W !,DGLIN2,!

 Q

 ;

MSG(DGN) ; -- prints message

 I $Y>(IOSL-4) D NEWPG Q:DGQ=U

 W !!,$P(^DPT(DFN,0),U),?25,$$HRC^ADGF(DFN),?35,$P($T(LINE+DGN),";;",2)

 Q

 ;

LINE ;;

 ;;V Hospitalization entry ADDED!

 ;;ERROR: Cannot add entry-call computer dept!

ADGVHF    ; IHS/ADC/PDW/ENM - CREATE VHOSP IF MISSING ; [ 03/25/1999  11:48 AM ]

 +1       ;;5.0;ADMISSION/DISCHARGE/TRANSFER;;MAR 25, 1999

 +2       ;

 +3       ;

 +4       ; -- select date range

DATE       SET %DT="AEQ"

           SET %DT("A")="Beginning date: "

           SET X=""

           DO ^%DT

 +1        IF Y=-1

               GOTO END

           SET DGBDT=Y

DATE2      SET %DT("A")="Ending date: "

           SET X=""

           DO ^%DT

           IF Y=-1

               GOTO DATE

           SET DGEDT=Y

 +1        IF DGEDT<DGBDT

               WRITE *7,!!?5,"Ending date MUST NOT be before beginning date",!

               GOTO DATE2

 +2        IF DGEDT'<DT

               SET X1=DT

               SET X2=-1

               DO C^%DTC

               SET DGEDT=X

 +3       ;

 +4       ; -- select print device

 +5        SET %ZIS="PQ"

           DO ^%ZIS

           IF POP

               GOTO END

           IF $DATA(IO("Q"))

               GOTO QUE

           USE IO

           GOTO LOOP

QUE        KILL IO("Q")

           SET ZTRTN="LOOP^ADGVHF"

           SET ZTDESC="FIX MISSING VHOSP"

 +1        FOR I="DGBDT","DGEDT"

               SET ZTSAVE(I)=""

 +2        DO ^%ZTLOAD

           DO ^%ZISC

           KILL ZTSK

 +3       ;

END        KILL Y,DGBDT,DGEDT

           DO HOME^%ZIS

           QUIT 

 +1       ;

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

 +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=""

           SET $PIECE(DGLIN,"=",80)=""

           SET DGLIN2=""

           SET $PIECE(DGLIN2,"-",80)=""

 +3        SET DGQ=""

           DO HED

 +4       ;

 +5        SET DGDT=DGBDT-.0001

           SET DGEND=DGEDT+.2400

 +6        FOR 

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

               IF DGDT=""!(DGDT>DGEND)!(DGQ=U)

                   QUIT 

               Begin DoDot:1

 +7                SET DGDSC=0

 +8                FOR 

                       SET DGDSC=$ORDER(^DGPM("ATT3",DGDT,DGDSC))

                       IF DGDSC=""!(DGQ=U)

                           QUIT 

                       Begin DoDot:2

 +9                        SET DGD=$GET(^DGPM(DGDSC,0))

                           IF DGD=""

                               QUIT 

 +10      ;corresponding adm

                           SET DGADM=$PIECE(^DGPM(DGDSC,0),U,14)

 +11                       SET DGA=$GET(^DGPM(DGADM,0))

                           IF DGA=""

                               QUIT 

 +12                       SET DGV=$PIECE($GET(^DGPM(DGADM,"IHS")),U)

 +13      ;entry okay

                           IF DGV]""

                               IF $ORDER(^AUPNVINP("AD",DGV,0))

                                   QUIT 

 +14                       DO ADD

                       End DoDot:2

               End DoDot:1

 +15      ;

 +16       KILL DFN,DGD,DGDUZ,DGLIN,DGLIN2,DGPG,DGSITE,DGTY

 +17       KILL DGQ,DGDT,DGBDT,DGEDT,DGEND,DGDSC,DGADM,DGA,DGV

           DO ^%ZISC

 +18       QUIT 

 +19      ;

 +20      ;

ADD       ; -- SUBRTN to set variables to call apcdalvr

 +1        DO ^APCDEIN

           SET DFN=$PIECE(DGA,U,3)

 +2        IF DGV=""

               Begin DoDot:1

 +3                NEW DGPMA,DGPMDA,DGPMCA

 +4                SET DGPMA=DGA

                   SET (DGPMDA,DGPMCA)=DGADM

                   DO APCDALV^ADGCALLS

 +5                SET DGV=$PIECE($GET(^DGPM(DGADM,"IHS")),U)

               End DoDot:1

 +6        SET APCDALVR("APCDPAT")=DFN

 +7        SET APCDALVR("APCDTDT")="`"_$PIECE(DGD,U,4)

 +8        SET APCDALVR("APCDATMP")="[APCDALVR 9000010.02 (ADD)]"

 +9        IF $PIECE(DGA,U,18)=10

               SET APCDALVR("APCDTTT")=$$TFAC

 +10       SET APCDALVR("APCDLOOK")=$EXTRACT(+DGD,1,12)

 +11       SET APCDALVR("APCDTDCS")="`"_$$DSRV

 +12       SET APCDALVR("APCDTADS")="`"_$PIECE(^DGPM($ORDER(^DGPM("APHY",DGADM,0)),0),U,9)

 +13       SET APCDALVR("APCDTAT")="`"_$PIECE(DGA,U,4)

 +14       SET APCDALVR("APCDVSIT")=DGV

 +15       DO ^APCDALVR

 +16       IF $DATA(APCDALVR("APCDAFLG"))

               DO MSG(2)

               DO NEWPG

               DO KILL

               QUIT 

 +17       DO MSG(1)

           DO KILL

           QUIT 

 +18      ;

KILL      ; -- kill apcd variables

 +1        DO APCDEKL^ADGCALLS

           QUIT 

 +2       ;

TFAC()    ; -- transfer facility

 +1        NEW X

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

 +2        QUIT $SELECT(X["DIC(4":"VA/IHS.`",1:"VENDOR.`")_+X

 +3       ;

DSRV()    ; -- discharge service

 +1        NEW X,Y

 +2        SET Y=9999999.9999999-$GET(^DGPM(+$PIECE(^DGPM(DGADM,0),U,17),0))

           IF 'Y

               QUIT 0

 +3        SET X=$ORDER(^DGPM("ATID6",+DFN,+$ORDER(^DGPM("ATID6",+DFN,Y)),0))

 +4        QUIT $PIECE($GET(^DGPM(+X,0)),U,9)

 +5       ;

NEWPG     ; -- end of page control

 +1        IF IOST'["C-"

               DO HED

               QUIT 

 +2        KILL DIR

           SET DIR(0)="E"

           DO ^DIR

           SET DGQ=X

 +3        IF DGQ'=U

               DO HED

 +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 !

           DO TIME^ADGUTIL

           WRITE ?80-$LENGTH(DGTY)/2,DGTY,?70,"Page: ",DGPG

 +6        SET Y=DT

           XECUTE ^DD("DD")

           WRITE !,Y

 +7        WRITE !,DGLIN2,!

 +8        QUIT 

 +9       ;

MSG(DGN)  ; -- prints message

 +1        IF $Y>(IOSL-4)

               DO NEWPG

               IF DGQ=U

                   QUIT 

 +2        WRITE !!,$PIECE(^DPT(DFN,0),U),?25,$$HRC^ADGF(DFN),?35,$PIECE($TEXT(LINE+DGN),";;",2)

 +3        QUIT 

 +4       ;

LINE      ;;

 +1       ;;V Hospitalization entry ADDED!

 +2       ;;ERROR: Cannot add entry-call computer dept!