- DGOVBC ;ALB/MRL - VBC DRIVER ROUTINE ; 12 FEB 87
- ;;5.3;Registration;**162,279,1015**;Aug 13, 1993;Build 21
- 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.
- DGOVBC ;ALB/MRL - VBC DRIVER ROUTINE ; 12 FEB 87
- +1 ;;5.3;Registration;**162,279,1015**;Aug 13, 1993;Build 21
- +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 DGOVBC_source.html#xD">DIC("S")="S DGOVBC_source.html#xD">DG36=$S($DGOVBC_source.html#xD">D(^(.36)):^(.36),1:0) I $S('DGOVBC_source.html#xD">DG36:1,'$DGOVBC_source.html#xD">D(^DGOVBC_source.html#xD">DIC(8,+$P(DGOVBC_source.html#xD">DG36,U,1),0)):1,$P(^DGOVBC_source.html#xD">DIC(8,+$P(DGOVBC_source.html#xD">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.
