source: FOIAVistA/trunk/r/AUTOMATED_MED_INFO_EXCHANGE-DVBA-DVBC/DVBASPD2.m

DVBASPD2 ;ALB/GTS-557/THM-AMIE SPECIAL REPORT ; 9/15/91  8:22 PM
 ;;2.7;AMIE;**3,57**;Apr 10, 1995
 K ^TMP($J) G TERM
SET Q:'$D(^DPT(DA,0))  S DFN=DA D RCV^DVBAVDPT Q:RCVPEN'=1&(REP="P")  Q:RCVAA'=1&(REP="A")  Q:CFLOC'=RONUM&(RO="Y")&(CFLOC'=0)&(CFLOC'=376)
 S DCHPTR=$P(^DGPM(MB,0),U,17),TDIS=$S($D(^DGPM(+DCHPTR,0)):$P(^(0),U,18),1:"")
 I +TDIS,'$D(^TMP("DVBA",$J,"DUP",+TDIS)) Q
 S TDIS=$S($P($G(^DG(405.2,+TDIS,0)),U,1)]"":$P(^(0),U,1),1:"Unknown discharge type")
 S ^TMP($J,XCN,CFLOC,MB,DA)=MA_U_RCVAA_U_RCVPEN_U_CNUM_U_TDIS
 Q
 ;
PRINTB W:(IOST?1"C-".E)!($D(DVBAON2)) @IOF
 W !!!,?(80-$L(HEAD)\2),HEAD,!,?(80-$L(HEAD1)\2),HEAD1,!!
 W ?10,REP(0),?26,PNAM,!!,?14,REP(1),?26,CNUM,!,?6,REP(2),?26,XCFLOC,!,?9,REP(3),?26,SSN,!,?8,REP(4),?26,ADMDT,!,?3,REP(5),?26,DIAG,!
 W ?8,REP(6),?26,DCHGDT,! W:DCHGDT]"" ?5,REP(7),?26,$$DIS,!
 W ?11,REP(8),?26,BEDSEC,!,?13,REP(9),?26,$$RAA,!
 W ?14,REP(10),?26,$$PEN,! D ELIG^DVBAVDPT
 I IOST?1"C-".E W *7,!,"Press RETURN to continue or ""^"" to stop    " R ANS:DTIME S:ANS=U!('$T) QUIT=1 I '$T S DVBAQUIT=1 I '$T S DVBAQUIT=1
 S DVBAON2=""
 Q
RAA() Q $S(RCVAA=0:"NO",RCVAA=1:"YES",1:"Not specified")
PEN() Q $S(RCVPEN=0:"NO",RCVPEN=1:"YES",1:"Not specified")
DIS() Q TDIS_$S(TO]"":" TO "_$S($D(^DIC(4,+TO,0)):$P(^(0),U,1),1:""),1:"")
SP(N,M) S $P(M," ",N-1)=" " Q M  ;pass one arg, 2nd for local use
PRINTC F J=0:1:7 S ^TMP("DVBSPCRP",$J,DVBC+J)=DVBS(J) ;NakedRefs = ^TMP("DVBSPCRP",$J,DVBC+J)
 S DVBC=DVBC+6,^TMP("DVBSPCRP",$J,DVBC)=$$SP(10)_REP(0)_PNAM
 S ^(DVBC+2)=$$SP(14)_REP(1)_CNUM
 S ^(DVBC+3)=$$SP(6)_REP(2)_XCFLOC
 S ^(DVBC+4)=$$SP(9)_REP(3)_SSN
 S ^(DVBC+5)=$$SP(8)_REP(4)_ADMDT
 S ^(DVBC+6)=$$SP(3)_REP(5)_DIAG
 S DVBC=DVBC+7,^(DVBC)=$$SP(8)_REP(6)_DCHGDT
 I DCHGDT]"" D
 .S DVBC=DVBC+1,^(DVBC)=$$SP(5)_REP(7)_$$DIS
 S ^(DVBC+1)=$$SP(11)_REP(8)_BEDSEC
 S ^(DVBC+2)=$$SP(13)_REP(9)_$$RAA
 S DVBC=DVBC+3,^(DVBC)=$$SP(14)_REP(10)_$$PEN
 D ELIG^DVBAVDPT
 Q
PRINT S QUIT="",XCN=""
 F  S XCN=$O(^TMP($J,XCN)) Q:XCN=""!(QUIT=1)  S XCFLOC="" F  S XCFLOC=$O(^TMP($J,XCN,XCFLOC)) Q:XCFLOC=""!(QUIT=1)  D PRINT1
 Q
PRINT1 S ADM="" F  S ADM=$O(^TMP($J,XCN,XCFLOC,ADM)) Q:ADM=""!(QUIT=1)  D
 .S DA="" F  S DA=$O(^TMP($J,XCN,XCFLOC,ADM,DA)) Q:DA=""!(QUIT=1)  D
 ..S DATA=^(DA),MA=$P(DATA,U),RCVAA=$P(DATA,U,2),RCVPEN=$P(DATA,U,3)
 ..S CNUM=$P(DATA,U,4),TDIS=$P(DATA,U,5),DFN=DA,TO="",QUIT1=1
 ..D ADM^DVBAVDPT
 ..S:ADMDT]"" ADMDT=$E(ADMDT,4,5)_"/"_$E(ADMDT,6,7)_"/"_$E(ADMDT,2,3)
 ..S:DCHGDT]"" DCHGDT=$E(DCHGDT,4,5)_"/"_$E(DCHGDT,6,7)_"/"_$E(DCHGDT,2,3)
 ..I $$BROKER^XWBLIB D PRINTC Q
 ..D PRINTB
 Q
SETUP S RPT="VARO REPORT"_$S(REP="A":" FOR A & A",1:" FOR PENSION"),DTAR=^DVB(396.1,1,0),FDT(0)=$E(DT,4,5)_"-"_$E(DT,6,7)_"-"_$E(DT,2,3)
 S HEAD="SPECIAL "_$S(REP="A":"A & A",1:"PENSION")_" REPORT",HEAD1="FOR "_$P(DTAR,U,1)_" ON "_FDT(0)
 S Y=$P(DTAR,U,9) X ^DD("DD") S REP("LRUN")="Last report was run on "_Y
 S REP(0)="Patient Name:",REP(1)="Claim No:"
 S REP(2)="Claim Folder Loc:",REP(3)="Social Sec No:"
 S REP(4)="Admission Date:",REP(5)="Admitting Diagnosis:"
 S REP(6)="Discharge Date:",REP(7)="Type of Discharge:"
 S REP(8)="Bed Service:",REP(9)="Recv A&A?:",REP(10)="Pension?:"
 Q
TERM D HOME^%ZIS,SETUP K NOASK
 W @IOF,!,RPT,!,HEAD1
 ;
EN1 W !!,"Please enter dates for search, oldest date first, most recent date last.",!!,REP("LRUN"),!!
 D DATE^DVBAUTIL
 G:X=""!(Y<0) KILL
 S %ZIS="Q" D ^%ZIS K %ZIS G:POP KILL^DVBAUTIL
 ;
QUEUE I $D(IO("Q")) S ZTRTN="DEQUE^DVBASPD2",ZTIO=ION,NOASK=1,ZTDESC="AMIE PENSION/A&A REPORT" F I="^TMP(""DVBA"",$J,""DUP"",","DVBATYPS","REP","FDT(0)","HEAD","HEAD1","BDATE","EDATE","TYPE","RO","RONUM","NOASK" S ZTSAVE(I)=""
 I $D(IO("Q")) D ^%ZTLOAD W:$D(ZTSK) !!,"Request queued.",!! G KILL
 ;
GO S MA=BDATE F  S MA=$O(^DGPM("AMV1",MA)) Q:$P(MA,".")>EDATE!(MA="")  W:'$D(NOASK) "." F DA=0:0 S DA=$O(^DGPM("AMV1",MA,DA)) Q:DA=""  F MB=0:0 S MB=$O(^DGPM("AMV1",MA,DA,MB)) Q:MB=""  D SET
 S:'$D(^TMP($J)) ER="No data found for parameters entered."
 G:$$BROKER^XWBLIB BROKER
 U IO I $D(ER) W !!,*7,ER,!! G KILL
 D PRINT
 I $D(DVBAQUIT) D:$D(ZTQUEUED) KILL^%ZTLOAD K ER,DVBAON2 G KILL^DVBAUTIL
 ;
KILL D ^%ZISC D:$D(ZTQUEUED) KILL^%ZTLOAD S X=9 K ER,DVBAON2 G FINAL^DVBAUTIL
 ;
INIT F J=0,2,5,6,7 S DVBS(J)=" "
 S $P(DVBS(1),"-",70)="-",DVBS(3)=$$SP(70-$L(HEAD)\2)_HEAD,DVBS(4)=$$SP(70-$L(HEAD1)\2)_HEAD1
 S ^TMP("DVBSPCRP",$J,1)=" ",^(2)=RPT,^(3)=HEAD1,^(4)=" ",^(5)=REP("LRUN"),DVBC=6
 F J=0:1:10 S REP(J)=REP(J)_"    "
 Q
BROKER I $D(ER) K ^TMP("DVBSPCRP",$J) S ^($J,1)=ER
 E  D INIT,PRINT
 S X=9 G FINAL^DVBAUTIL
 ;
SPECRPT(ZMSG,DCTYPES,BDATE,EDATE,RONUM,REP)      ;
 N I,J,REQ,DVBC,DVBACEPT,DVBS,ER
 S ZMSG=$NA(^TMP("DVBSPCRP",$J)),RONUM=+$G(RONUM),REQ=" IS REQUIRED"
 S MB=" MUST BE ",TYPE="REPORT TYPE",BDT="BEGINNING DATE",EDT="ENDING DATE"
 I $G(BDATE)="" S ER=BDT_REQ
 I $G(EDATE)="" S ER=EDT_REQ
 I EDATE<BDATE S ER=BDT_MB_"BEFORE THE "_EDT
 I $G(REP)="" S ER=TYPE_REQ
 I "^A^P"'[REP S ER=TYPE_MB_"'A' OR 'P'"
 I $D(RONUM)&(RONUM'?1.3N) S ER="REGIONAL OFFICE"_MB_"1-3 NUMBERS"
 K ^TMP("DVBSPCRP",$J) I $D(ER) S ^($J,1)=ER,X=9 G FINAL^DVBAUTIL
 S (NOASK,DVBACEPT)=1,RO=$S(RONUM=0:"N",1:"Y")
 F J=0:0 S J=$O(DCTYPES(J)) Q:'J  S ^TMP("DVBA",$J,"DUP",DCTYPES(J))=""
 D SETUP
DEQUE K ^TMP($J) G GO
 ;