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!
