DGOVBC ;ALB/MRL - VBC DRIVER ROUTINE ; 12 FEB 87
;;5.3;Registration;**162,279**;Aug 13, 1993
W ! D DT^DICRW S IOP="HOME" D ^%ZIS K IOP I $D(IOF),IOF']"" W @IOF
1 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
P 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)
OK 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
2 W ! F I=1:1 S J=$P($T(T+I),";;",2) Q:J']"" W !,J
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"
D 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
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
M S DGDFN=DGFR_"^"_DGTO
;Ask division (sets VAUTD)
W ! Q:'$$ASKDIV^DGUTL()
QUE 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
G @DGPGM
S 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
G ^DGOVBC1
A 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
G ^DGOVBC1
A1 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
.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))
.S ^UTILITY($J,"DGOVBC",$P(^DPT(DFN,0),"^",1))=DFN
Q
SET 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
ERR S Y=-1 K DIC,SDALL,SDEF Q
T ;
;;This option is used to generate the 'VETERANS ASSISTANCE UNIT RECORD' for any
;;veterans admitted during a specified date range. The user will be prompted to
;;select the 'Start with' and 'Go To' range for admissions and the DEVICE desired
;;for output. A VBC document will be generated only for those patients admitted
;;during the requested timeframe who are veterans.
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGOVBC 2793 printed Dec 13, 2024@02:47:06 Page 2
DGOVBC ;ALB/MRL - VBC DRIVER ROUTINE ; 12 FEB 87
+1 ;;5.3;Registration;**162,279**;Aug 13, 1993
+2 WRITE !
DO DT^DICRW
SET IOP="HOME"
DO ^%ZIS
KILL IOP
IF $DATA(IOF)
IF IOF']""
WRITE @IOF
1 WRITE !
SET DGHOW="S"
SET VAUTNALL=""
SET VAUTNI=2
SET 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)"
DO PATIENT^VAUTOMA
IF Y<0
GOTO Q^DGOVBC1
P WRITE !!,"DISPLAY THE FOLLOWING PATIENTS",!,"------------------------------"
SET DFN=0
FOR DFN1=0:0
SET DFN=$ORDER(VAUTN(DFN))
if DFN=""
QUIT
IF $DATA(^DPT(DFN,0))
SET X=^(0)
SET Y=$PIECE(X,"^",3)
if Y]""
XECUTE ^DD("DD")
WRITE !,$PIECE(X,"^",1),?40,Y,?60,$PIECE(X,"^",9)
OK WRITE !!,"IS THIS CORRECT"
SET %=2
DO YN^DICN
if %=1
GOTO QUE
if %=2!(%=-1)
GOTO Q^DGOVBC1
WRITE !!?4,"Y - If you want to see VBC data for these patients.",!?4,"N - If you want to QUIT and reconsider this action."
GOTO OK
2 WRITE !
FOR I=1:1
SET J=$PIECE($TEXT(T+I),";;",2)
if J']""
QUIT
WRITE !,J
+1 DO DT^DICRW
WRITE !!
SET DGHOW="A"
SET %DT="EAX"
SET %DT("A")="Start with ADMISSION DATE: "
DO ^%DT
if Y'>0
GOTO Q^DGOVBC1
SET (DGFR,DGHFR)=Y
SET X1=DGFR
SET X2=-1
DO C^%DTC
SET DGFR=X_".9999"
D SET Y=DT
SET %DT(0)=DGHFR
KILL DGHFR
XECUTE ^DD("DD")
SET %DT("A")=" Go to ADMISSION DATE: "_Y_"// "
DO ^%DT
IF X']""
SET DGTO=DT_".9999"
GOTO M
+1 if Y'>0
GOTO Q^DGOVBC1
SET DGTO=Y_".9999"
IF DGFR>DGTO
WRITE !?4,"TO DATE CAN'T BE BEFORE FROM DATE!!",*7,!
GOTO D
M SET DGDFN=DGFR_"^"_DGTO
+1 ;Ask division (sets VAUTD)
+2 WRITE !
if '$$ASKDIV^DGUTL()
QUIT
QUE WRITE !!,*7,"Note: This report requires a column width of 132."
SET DGPGM=DGHOW_"^DGOVBC"
SET DGVAR="DUZ^DGDFN^VAUTN#^VAUTD#"
DO ZIS^DGUTQ
if POP
GOTO Q^DGOVBC1
USE IO
+1 GOTO @DGPGM
S DO SET
SET DFN=0
FOR DFN1=0:0
SET DFN=$ORDER(VAUTN(DFN))
if DFN=""
QUIT
IF $DATA(^DPT(DFN,0))
IF $PIECE(^(0),"^",1)]""
SET ^UTILITY($JOB,"DGOVBC",$PIECE(^DPT(DFN,0),"^",1))=DFN
+1 GOTO ^DGOVBC1
A DO SET
SET DGFR=$PIECE(DGDFN,"^",1)
SET DGTO=$PIECE(DGDFN,"^",2)
FOR I=0:0
SET DGFR=$ORDER(^DGPM("AMV1",DGFR))
if 'DGFR!(DGFR>DGTO)
QUIT
FOR DFN=0:0
SET DFN=$ORDER(^DGPM("AMV1",DGFR,DFN))
if 'DFN
QUIT
FOR DGCA=0:0
SET DGCA=$ORDER(^DGPM("AMV1",DGFR,DFN,DGCA))
if 'DGCA
QUIT
IF $DATA(^DGPM(DGCA,0))
DO A1
+1 GOTO ^DGOVBC1
A1 IF $DATA(^DPT(DFN,0))
IF $PIECE(^(0),"^",1)]""
IF $DATA(^DPT(DFN,.36))
SET X=$PIECE(^(.36),"^",1)
IF $DATA(^DIC(8,+X,0))
IF $PIECE(^(0),"^",5)="Y"
Begin DoDot:1
+1 IF 'VAUTD
SET DGWD=+$PIECE($GET(^DGPM(DGCA,0)),U,6)
if 'DGWD
QUIT
SET DGWD=+$PIECE($GET(^DIC(42,DGWD,0)),U,11)
if '$DATA(VAUTD(DGWD))
QUIT
+2 SET ^UTILITY($JOB,"DGOVBC",$PIECE(^DPT(DFN,0),"^",1))=DFN
End DoDot:1
+3 QUIT
SET SET U="^"
SET DGHD=$SELECT($DATA(^DD("SITE"))#2:^("SITE"),1:"")_$SELECT($DATA(^DD("SITE",1)):" ("_^(1)_")",1:"")
SET DGHD1=1-$LENGTH(DGHD)-1
SET DGLIN=""
SET $PIECE(DGLIN,"=",131)=""
KILL ^UTILITY($JOB,"DGOVBC")
QUIT
ERR SET Y=-1
KILL DIC,SDALL,SDEF
QUIT
T ;
+1 ;;This option is used to generate the 'VETERANS ASSISTANCE UNIT RECORD' for any
+2 ;;veterans admitted during a specified date range. The user will be prompted to
+3 ;;select the 'Start with' and 'Go To' range for admissions and the DEVICE desired
+4 ;;for output. A VBC document will be generated only for those patients admitted
+5 ;;during the requested timeframe who are veterans.
