source: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGOVBC.m@ 1578

Last change on this file since 1578 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 2.7 KB
Line 
1DGOVBC ;ALB/MRL - VBC DRIVER ROUTINE ; 12 FEB 87
2 ;;5.3;Registration;**162,279**;Aug 13, 1993
3 W ! D DT^DICRW S IOP="HOME" D ^%ZIS K IOP I $D(IOF),IOF']"" W @IOF
41 W ! S DGHOW="S",VAUTNALL="",VAUTNI=2,DIC("S")="S DG36=$S($D(^(.36)):^(.36),1:0) I $S('DG36:1,'$D(^DIC(8,+$P(DG36,U,1),0)):1,$P(^DIC(8,+$P(DG36,U,1),0),U,5)=""Y"":1,1:0)" D PATIENT^VAUTOMA I Y<0 G Q^DGOVBC1
5P W !!,"DISPLAY THE FOLLOWING PATIENTS",!,"------------------------------" S DFN=0 F DFN1=0:0 S DFN=$O(VAUTN(DFN)) Q:DFN="" I $D(^DPT(DFN,0)) S X=^(0),Y=$P(X,"^",3) X:Y]"" ^DD("DD") W !,$P(X,"^",1),?40,Y,?60,$P(X,"^",9)
6OK W !!,"IS THIS CORRECT" S %=2 D YN^DICN G QUE:%=1,Q^DGOVBC1:%=2!(%=-1) W !!?4,"Y - If you want to see VBC data for these patients.",!?4,"N - If you want to QUIT and reconsider this action." G OK
72 W ! F I=1:1 S J=$P($T(T+I),";;",2) Q:J']"" W !,J
8 D DT^DICRW W !! S DGHOW="A",%DT="EAX",%DT("A")="Start with ADMISSION DATE: " D ^%DT G Q^DGOVBC1:Y'>0 S (DGFR,DGHFR)=Y,X1=DGFR,X2=-1 D C^%DTC S DGFR=X_".9999"
9D S Y=DT,%DT(0)=DGHFR K DGHFR X ^DD("DD") S %DT("A")=" Go to ADMISSION DATE: "_Y_"// " D ^%DT I X']"" S DGTO=DT_".9999" G M
10 G Q^DGOVBC1:Y'>0 S DGTO=Y_".9999" I DGFR>DGTO W !?4,"TO DATE CAN'T BE BEFORE FROM DATE!!",*7,! G D
11M S DGDFN=DGFR_"^"_DGTO
12 ;Ask division (sets VAUTD)
13 W ! Q:'$$ASKDIV^DGUTL()
14QUE W !!,*7,"Note: This report requires a column width of 132." S DGPGM=DGHOW_"^DGOVBC",DGVAR="DUZ^DGDFN^VAUTN#^VAUTD#" D ZIS^DGUTQ G Q^DGOVBC1:POP U IO
15 G @DGPGM
16S D SET S DFN=0 F DFN1=0:0 S DFN=$O(VAUTN(DFN)) Q:DFN="" I $D(^DPT(DFN,0)),$P(^(0),"^",1)]"" S ^UTILITY($J,"DGOVBC",$P(^DPT(DFN,0),"^",1))=DFN
17 G ^DGOVBC1
18A D SET S DGFR=$P(DGDFN,"^",1),DGTO=$P(DGDFN,"^",2) F I=0:0 S DGFR=$O(^DGPM("AMV1",DGFR)) Q:'DGFR!(DGFR>DGTO) F DFN=0:0 S DFN=$O(^DGPM("AMV1",DGFR,DFN)) Q:'DFN F DGCA=0:0 S DGCA=$O(^DGPM("AMV1",DGFR,DFN,DGCA)) Q:'DGCA I $D(^DGPM(DGCA,0)) D A1
19 G ^DGOVBC1
20A1 I $D(^DPT(DFN,0)),$P(^(0),"^",1)]"",$D(^DPT(DFN,.36)) S X=$P(^(.36),"^",1) I $D(^DIC(8,+X,0)),$P(^(0),"^",5)="Y" D
21 .I 'VAUTD S DGWD=+$P($G(^DGPM(DGCA,0)),U,6) Q:'DGWD S DGWD=+$P($G(^DIC(42,DGWD,0)),U,11) Q:'$D(VAUTD(DGWD))
22 .S ^UTILITY($J,"DGOVBC",$P(^DPT(DFN,0),"^",1))=DFN
23 Q
24SET S U="^",DGHD=$S($D(^DD("SITE"))#2:^("SITE"),1:"")_$S($D(^DD("SITE",1)):" ("_^(1)_")",1:""),DGHD1=1-$L(DGHD)-1,DGLIN="",$P(DGLIN,"=",131)="" K ^UTILITY($J,"DGOVBC") Q
25ERR S Y=-1 K DIC,SDALL,SDEF Q
26T ;
27 ;;This option is used to generate the 'VETERANS ASSISTANCE UNIT RECORD' for any
28 ;;veterans admitted during a specified date range. The user will be prompted to
29 ;;select the 'Start with' and 'Go To' range for admissions and the DEVICE desired
30 ;;for output. A VBC document will be generated only for those patients admitted
31 ;;during the requested timeframe who are veterans.
Note: See TracBrowser for help on using the repository browser.