DVBAPND1 ;ALB ISC/GTS-AMIE PENDING RPT UT ;13 JAN 93@08:10 ; 7/2/90 2:48 PM
;;2.7;AMIE;**14,17**;Apr 10, 1995
;
; ** The following routines are called from DVBAPEND **
SORTDIV W !!,"Sort by Division" S %=1 D YN^DICN
I $D(DTOUT)!(%<0) K DTOUT S Y=-1 Q
I $D(%Y),(%Y["?") W !!,*7,"Enter Y to sort by the Division you"
I $D(%Y),(%Y["?") W !,"select or enter N to report ALL Divisions."
I $D(%Y),(%Y["?") G SORTDIV
I %'=1 S SELDIV="N",DIVNUM=0 Q
I %=1 S SELDIV="Y" G ENTDIV
W !,*7,"Invalid response.",!! G SORTDIV
; ** Allow user to enter a selected Division to report **
ENTDIV S DIC="^DG(40.8,",DIC(0)="AEMQ",DIC("A")="Division number: "
D ^DIC K DIC S DIVNUM=+Y
S DIVNAM=$S($D(^DG(40.8,+Y,0)):$P(^(0),"^",1),1:"Unknown Division")
Q
;
DCHGDT S DCHGDT="",DCHPTR=$P(^DGPM(XJ,0),U,17),XADMDT=$P(^(0),U,1) I DCHPTR]"",$D(^DGPM(+DCHPTR,0)) S DCHGDT=$P(^DGPM(+DCHPTR,0),U,1)
K DCHPTR
Q
;
PRINT S DOCTYPE=$S($D(^DVB(396,DA,2)):$P(^(2),U,10),1:""),DFN=$P(^DVB(396,DA,0),U,1),ADMDT=$P(^(0),U,4),RDATE=$P(^(1),U,1),PNAM=$P(^DPT(DFN,0),U,1),SSN=$P(^(0),U,9),CNUM=$S($D(^(.31)):$P(^(.31),U,3),1:"UNKNOWN")
I RO="Y" S CFLOC=$$STATION^DVBAUTL1(DFN),CFLOC=$S(CFLOC>0:CFLOC,1:9999) Q:CFLOC'=RONUM&(CFLOC'=0)&(CFLOC'=376)
K ^TMP("DVBA","ADMIT",$J)
F XI=0:0 S XI=$O(^DGPM("APTT1",DFN,XI)) Q:XI="" F XJ=0:0 S XJ=$O(^DGPM("APTT1",DFN,XI,XJ)) Q:XJ="" D DCHGDT S ^TMP("DVBA","ADMIT",$J,XADMDT,DFN)=XI_U_DCHGDT
W:SELDIV="Y" !,?10,"Division: "_ADIV,!
W:SELDIV="N" !,?10,"Original Division: "_ADIV,!
W !,PNAM,?49,"SSN: ",SSN,!,?44,"Claim no: ",CNUM,!,?38,$S(DOCTYPE="L":" Activity date: ",1:"Admission date: "),$$FMTE^XLFDT(ADMDT,"5DZ"),!,?40,"Request date: ",$$FMTE^XLFDT(RDATE,"5DZ")
S DCHGDT=""
I $D(^TMP("DVBA","ADMIT",$J,+ADMDT,DFN)) S:DOCTYPE="A" DCHGDT=$P(^TMP("DVBA","ADMIT",$J,+ADMDT,DFN),U,2)
D ELAPSED
W ! I DCHGDT]"" S Y=DCHGDT X DVBADD W "** Discharged: ",Y
W ?40,"Elapsed days: ",EDAYS,!!,?3,"Items Pending:"
ITEMS F Q=9,11,13,15,17,19,21,23,26,28 I $P(^DVB(396,DA,0),U,Q)="P" D PRINT1 Q:DVBAQUIT=1
S Q=7 I $P(^DVB(396,DA,1),U,Q)="P" D PRINT1 Q:DVBAQUIT=1
W !! W:$D(^DVB(396,DA,2)) "Requested by: ",$S($P(^DVB(396,DA,2),U,8)]"":$P(^(2),U,8),1:" (Not specified) ")," AT ",$S($P(^(2),U,7)]"":$P(^(2),U,7),1:" (Not specified) "),! F L=1:1:79 W "-"
W !
D TOP Q:DVBAQUIT=1
Q
;
PRINT1 S:$D(^DVB(396,DA,6)) GDIVPTR=$P(^DVB(396,DA,6),"^",Q)
S:'$D(^DVB(396,DA,6)) GDIVPTR=$P(^DVB(396,DA,2),"^",9)
S:+GDIVPTR>0 GDIVNAM=$P(^DG(40.8,GDIVPTR,0),"^",1)
S:+GDIVPTR'>0 GDIVNAM=""
S NODTA=1 I QQ S MC=$T(@Q),MD=$P(MC,";;",2) S GDIV=" ("_$E(GDIVNAM,1,(9+(23-$L(MC))))_")" W !,?8,MD,GDIV S QQ='QQ Q
I 'QQ S MC=$T(@Q),MD=$P(MC,";;",2) S GDIV=" ("_$E(GDIVNAM,1,(9+(23-$L(MC))))_")" W ?46,MD,GDIV S QQ='QQ I $Y>22 D TOP Q:DVBAQUIT=1
Q
;
TOP I IOST?1"C-".E,'$D(NOASK) W !!,*7,"Press RETURN to continue or ""^"" to exit " R ANS:DTIME W @IOF I ANS=U!('$T) S DVBAQUIT=1 Q
I $Y'<53 D HEADER
Q
;
ELAPSED K EDAYS,X1,X S X1=DT,X=RDATE D ^XUWORKDY
S EDAYS=X
Q
;
W ?(80-$L(HEAD)\2),HEAD,?71,"Page: ",PG,! I HEAD2]"" W ?(80-$L(HEAD2)\2),HEAD2,!
W ?(80-$L(PROCDT)\2),PROCDT,!!
Q
FIELDS ;
7 ;;ADMISSION RPT
9 ;;NOTICE OF DISCHARGE
11 ;;HOSPITAL SUMMARY
13 ;;21-DAY CERTIFICATE
15 ;;OTHER/EXAM REVIEW RMKS
17 ;;SPECIAL REPORT
19 ;;COMPETENCY REPORT
21 ;;VA FORM 21-2680
23 ;;ASSET INFORMATION
26 ;;OPT TREATMENT REPORT
28 ;;BEGINNING DATE/CARE
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBAPND1 3477 printed Nov 22, 2024@16:52 Page 2
DVBAPND1 ;ALB ISC/GTS-AMIE PENDING RPT UT ;13 JAN 93@08:10 ; 7/2/90 2:48 PM
+1 ;;2.7;AMIE;**14,17**;Apr 10, 1995
+2 ;
+3 ; ** The following routines are called from DVBAPEND **
SORTDIV WRITE !!,"Sort by Division"
SET %=1
DO YN^DICN
+1 IF $DATA(DTOUT)!(%<0)
KILL DTOUT
SET Y=-1
QUIT
+2 IF $DATA(%Y)
IF (%Y["?")
WRITE !!,*7,"Enter Y to sort by the Division you"
+3 IF $DATA(%Y)
IF (%Y["?")
WRITE !,"select or enter N to report ALL Divisions."
+4 IF $DATA(%Y)
IF (%Y["?")
GOTO SORTDIV
+5 IF %'=1
SET SELDIV="N"
SET DIVNUM=0
QUIT
+6 IF %=1
SET SELDIV="Y"
GOTO ENTDIV
+7 WRITE !,*7,"Invalid response.",!!
GOTO SORTDIV
+8 ; ** Allow user to enter a selected Division to report **
ENTDIV SET DIC="^DG(40.8,"
SET DIC(0)="AEMQ"
SET DIC("A")="Division number: "
+1 DO ^DIC
KILL DIC
SET DIVNUM=+Y
+2 SET DIVNAM=$SELECT($DATA(^DG(40.8,+Y,0)):$PIECE(^(0),"^",1),1:"Unknown Division")
+3 QUIT
+4 ;
DCHGDT SET DCHGDT=""
SET DCHPTR=$PIECE(^DGPM(XJ,0),U,17)
SET XADMDT=$PIECE(^(0),U,1)
IF DCHPTR]""
IF $DATA(^DGPM(+DCHPTR,0))
SET DCHGDT=$PIECE(^DGPM(+DCHPTR,0),U,1)
+1 KILL DCHPTR
+2 QUIT
+3 ;
PRINT SET DOCTYPE=$SELECT($DATA(^DVB(396,DA,2)):$PIECE(^(2),U,10),1:"")
SET DFN=$PIECE(^DVB(396,DA,0),U,1)
SET ADMDT=$PIECE(^(0),U,4)
SET RDATE=$PIECE(^(1),U,1)
SET PNAM=$PIECE(^DPT(DFN,0),U,1)
SET SSN=$PIECE(^(0),U,9)
SET CNUM=$SELECT($DATA(^(.31)):$PIECE(^(.31),U,3),1:"UNKNOWN")
+1 IF RO="Y"
SET CFLOC=$$STATION^DVBAUTL1(DFN)
SET CFLOC=$SELECT(CFLOC>0:CFLOC,1:9999)
if CFLOC'=RONUM&(CFLOC'=0)&(CFLOC'=376)
QUIT
+2 KILL ^TMP("DVBA","ADMIT",$JOB)
+3 FOR XI=0:0
SET XI=$ORDER(^DGPM("APTT1",DFN,XI))
if XI=""
QUIT
FOR XJ=0:0
SET XJ=$ORDER(^DGPM("APTT1",DFN,XI,XJ))
if XJ=""
QUIT
DO DCHGDT
SET ^TMP("DVBA","ADMIT",$JOB,XADMDT,DFN)=XI_U_DCHGDT
+4 if SELDIV="Y"
WRITE !,?10,"Division: "_ADIV,!
+5 if SELDIV="N"
WRITE !,?10,"Original Division: "_ADIV,!
+6 WRITE !,PNAM,?49,"SSN: ",SSN,!,?44,"Claim no: ",CNUM,!,?38,$SELECT(DOCTYPE="L":" Activity date: ",1:"Admission date: "),$$FMTE^XLFDT(ADMDT,"5DZ"),!,?40,"Request date: ",$$FMTE^XLFDT(RDATE,"5DZ")
+7 SET DCHGDT=""
+8 IF $DATA(^TMP("DVBA","ADMIT",$JOB,+ADMDT,DFN))
if DOCTYPE="A"
SET DCHGDT=$PIECE(^TMP("DVBA","ADMIT",$JOB,+ADMDT,DFN),U,2)
+9 DO ELAPSED
+10 WRITE !
IF DCHGDT]""
SET Y=DCHGDT
XECUTE DVBADD
WRITE "** Discharged: ",Y
+11 WRITE ?40,"Elapsed days: ",EDAYS,!!,?3,"Items Pending:"
ITEMS FOR Q=9,11,13,15,17,19,21,23,26,28
IF $PIECE(^DVB(396,DA,0),U,Q)="P"
DO PRINT1
if DVBAQUIT=1
QUIT
+1 SET Q=7
IF $PIECE(^DVB(396,DA,1),U,Q)="P"
DO PRINT1
if DVBAQUIT=1
QUIT
+2 WRITE !!
if $DATA(^DVB(396,DA,2))
WRITE "Requested by: ",$SELECT($PIECE(^DVB(396,DA,2),U,8)]"":$PIECE(^(2),U,8),1:" (Not specified) ")," AT ",$SELECT($PIECE(^(2),U,7)]"":$PIECE(^(2),U,7),1:" (Not specified) "),!
FOR L=1:1:79
WRITE "-"
+3 WRITE !
+4 DO TOP
if DVBAQUIT=1
QUIT
+5 QUIT
+6 ;
PRINT1 if $DATA(^DVB(396,DA,6))
SET GDIVPTR=$PIECE(^DVB(396,DA,6),"^",Q)
+1 if '$DATA(^DVB(396,DA,6))
SET GDIVPTR=$PIECE(^DVB(396,DA,2),"^",9)
+2 if +GDIVPTR>0
SET GDIVNAM=$PIECE(^DG(40.8,GDIVPTR,0),"^",1)
+3 if +GDIVPTR'>0
SET GDIVNAM=""
+4 SET NODTA=1
IF QQ
SET MC=$TEXT(@Q)
SET MD=$PIECE(MC,";;",2)
SET GDIV=" ("_$EXTRACT(GDIVNAM,1,(9+(23-$LENGTH(MC))))_")"
WRITE !,?8,MD,GDIV
SET QQ='QQ
QUIT
+5 IF 'QQ
SET MC=$TEXT(@Q)
SET MD=$PIECE(MC,";;",2)
SET GDIV=" ("_$EXTRACT(GDIVNAM,1,(9+(23-$LENGTH(MC))))_")"
WRITE ?46,MD,GDIV
SET QQ='QQ
IF $Y>22
DO TOP
if DVBAQUIT=1
QUIT
+6 QUIT
+7 ;
TOP IF IOST?1"C-".E
IF '$DATA(NOASK)
WRITE !!,*7,"Press RETURN to continue or ""^"" to exit "
READ ANS:DTIME
WRITE @IOF
IF ANS=U!('$TEST)
SET DVBAQUIT=1
QUIT
+1 IF $Y'<53
DO HEADER
+2 QUIT
+3 ;
ELAPSED KILL EDAYS,X1,X
SET X1=DT
SET X=RDATE
DO ^XUWORKDY
+1 SET EDAYS=X
+2 QUIT
+3 ;
if (IOST?1"C-".E)!(PG>1)
WRITE @IOF,!
+1 WRITE ?(80-$LENGTH(HEAD)\2),HEAD,?71,"Page: ",PG,!
IF HEAD2]""
WRITE ?(80-$LENGTH(HEAD2)\2),HEAD2,!
+2 WRITE ?(80-$LENGTH(PROCDT)\2),PROCDT,!!
+3 QUIT
FIELDS ;
7 ;;ADMISSION RPT
9 ;;NOTICE OF DISCHARGE
11 ;;HOSPITAL SUMMARY
13 ;;21-DAY CERTIFICATE
15 ;;OTHER/EXAM REVIEW RMKS
17 ;;SPECIAL REPORT
19 ;;COMPETENCY REPORT
21 ;;VA FORM 21-2680
23 ;;ASSET INFORMATION
26 ;;OPT TREATMENT REPORT
28 ;;BEGINNING DATE/CARE
+1 QUIT
