Changeset 623 for WorldVistAEHR/trunk/r/FEE_BASIS-FB
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- Location:
- WorldVistAEHR/trunk/r/FEE_BASIS-FB
- Files:
-
- 17 edited
-
FBAA79.m (modified) (1 diff)
-
FBAA79A.m (modified) (1 diff)
-
FBAAAUT.m (modified) (1 diff)
-
FBAADEM1.m (modified) (1 diff)
-
FBAAFSR.m (modified) (1 diff)
-
FBCH78.m (modified) (1 diff)
-
FBCH78A.m (modified) (1 diff)
-
FBCHP78.m (modified) (1 diff)
-
FBCHREQ1.m (modified) (1 diff)
-
FBCTAU.m (modified) (2 diffs)
-
FBCTAU1.m (modified) (2 diffs)
-
FBCTAU2.m (modified) (1 diff)
-
FBCTAU3.m (modified) (1 diff)
-
FBNHEAU1.m (modified) (1 diff)
-
FBNHEAUT.m (modified) (1 diff)
-
FBNHEDAT.m (modified) (1 diff)
-
FBPCR.m (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBAA79.m
r613 r623 1 FBAA79 ;AISC/GRR-PRINT FORM 7079 REQUEST FOR OUTPATIENT MEDICAL SERVICES ;7/NOV/2006 2 ;;3.5;FEE BASIS;**12,23,101,103**;JAN 30, 1995;Build 19 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 W !,"Print 7079's for: " D DT^DICRW,DATE^FBAAUTL G:FBPOP END D SITEP^FBAAUTL G:FBPOP END 5 I '$D(^FBAAA("AF",2)) W !!,*7,"There are no 7079's to be printed!",! G END 6 S FBAASCR="" 7 RDHOW W ! S DIR("A")="Want only those that have not yet been printed",DIR("B")="Yes",DIR(0)="Y" D ^DIR K DIR G END:$D(DIRUT) S:Y FBAASCR="Y" 8 D OUTPUT^FBAAS79 9 S VAR="BEGDATE^ENDDATE^FBAASCR",VAL=BEGDATE_"^"_ENDDATE_"^"_FBAASCR,PGM="START^FBAA79",IOP="Q" D ZIS^FBAAUTL G:FBPOP END 10 START D SITEP^FBAAUTL G END:FBPOP 11 S UL="",ULL="----------",FBPG=0 F Z=1:1:12 S UL=UL_ULL 12 U IO S FBAASCR=$S(FBAASCR="":"I 1",FBAASCR="Y":"I $S('$D(^FBAAA(DFN,1,FBK,1)):1,$P(^FBAAA(DFN,1,FBK,1),""^"",2)']"""":1,1:0)",1:"I 1") 13 S FBJ=BEGDATE-.001,(DFN,FBK)=0 F ZZ=0:0 S FBJ=$O(^FBAAA("AF",2,FBJ)) Q:FBJ'>0!(FBJ>ENDDATE) F S DFN=$O(^FBAAA("AF",2,FBJ,DFN)) Q:DFN'>0 F S FBK=$O(^FBAAA("AF",2,FBJ,DFN,FBK)) Q:FBK'>0 X FBAASCR I D GOT 14 END K FBJ,FBK,DFN,Z,FBS,V,FBI,FBPATT,FBPG,FBSITE,UL,ULL,POV,NOV,POS,CC,PSTCD,SSTCD,VSTCD,BEGDATE,ENDDATE,PIDC,REF,VDX,CODE,STATCD,D,FBAASCR,FBDX,FBIDC,FBOUT,FBPDX,FBREM,FBRR,NAME,PGM,POW,VAL,VAR,VFN,VFROM,VTO,YOB,ZZ 15 K FB7078,FBAABDT,FBAAEDT,FBASSOC,FBLOC,FBPOV,FBPSA,FBPT,FBTT,FBTYPE,FBVEN,FTP,CNT,FBAAOUT,FBAUT,FBPROG,I,J,M,PI,Q,SEX,SSN,TA,DATE,S,Y,DA,DIC 16 D CLOSE^FBAAUTL Q 17 Q 18 ; 19 ; Utilize new API for Name Standardization 20 ; 21 GOT Q:'$D(^DPT(DFN,0)) 22 S Y(0)=^DPT(DFN,0) 23 D 24 .N FBNAMES 25 .S FBNAMES("FILE")=2,FBNAMES("IENS")=DFN_",",FBNAMES("FIELD")=.01 26 .S NAME=$$NAMEFMT^XLFNAME(.FBNAMES) 27 S SEX=$P(Y(0),U,2) 28 S SSN=$TR($$SSNL4^FBAAUTL($$SSN^FBAAUTL(DFN)),"-",""),YOB=$S($P(Y(0),U,3)]"":$E($P(Y(0),U,3),1,3)+1700,1:""),POS=$S($D(^DPT(DFN,.32)):$P(^(.32),"^",3),1:""),POS=$S(POS]"":$P(^DIC(21,POS,0),"^",3),1:"") 29 F I=1:1:7 S FBI(I)="" 30 I $D(^DPT(DFN,.11)) F I=1:1:7 S FBI(I)=$P(^(.11),"^",I) 31 S POW=$P($G(^DPT(DFN,.52)),"^",5) 32 Q:'$D(^FBAAA(DFN,1,FBK)) S Y(0)=^(FBK,0),VFROM=$P(Y(0),"^",1),VTO=$P(Y(0),"^",2),VFN=$P(Y(0),"^",4) I $S($P(Y(0),"^",3)=6:1,$P(Y(0),"^",3)=7:1,1:"") Q 33 S VDX=$P(Y(0),"^",8),FBPATT=$P(Y(0),"^",18),POV=$$EXTPV^FBAAUTL5($P(Y(0),"^",7)),CODE=$P(Y(0),"^",13),PIDC=$P(Y(0),"^",12),REF=$P(Y(0),"^",21) 34 S NOV=$P($G(^FBAAA(DFN,1,FBK,1)),"^") 35 S FBDX=$G(^FBAAA(DFN,1,FBK,3)) 36 S FBIDC=$P($G(^FBAAA(DFN,4)),"^") 37 S STATCD=FBI(5),CC=FBI(7) F V=1:1:14 S V(V)="" 38 S CC=$S(CC']"":"",$D(^DIC(5,+STATCD,1,CC,0)):$P(^(0),"^",3),1:"") 39 S Y(0)=$S(VFN']"":"",'$D(^FBAAV(VFN,0)):"",$D(^FBAAV(VFN,0)):^(0),1:"") G:$S(VFN']"":1,'$D(^FBAAV(VFN,0)):1,1:0) OVR 40 F V=2,1,3,14,4,5,6,10 S V(V)=$P(Y(0),"^",V) 41 OVR F S=1:1:9 S FBS(S)=$P(FBSITE(0),"^",S) 42 S VSTCD=$S(V(5)']"":" ",$D(^DIC(5,V(5),0)):$P(^(0),"^",2),1:" "),SSTCD=$S(FBS(5)']"":" ",$D(^DIC(5,+FBS(5),0)):$P(^(0),"^",2),1:" "),PSTCD=$S(FBI(5)']"":" ",$D(^DIC(5,+FBI(5),0)):$P(^(0),"^",2),1:" ") 43 W:FBPG @IOF W UL,!,?46,"Department of Veterans Affairs",?100,"ID Card Number: ",FBIDC,!,?35,"R E Q U E S T F O R O U T P A T I E N T S E R V I C E S",!,UL S FBREM=0,FBOUT=0 44 ; 45 W !,"(1) Veterans Name",?31,"|(2) ID Number | Period of Validity",!,?31,"|",?46,"|" 46 W !,NAME,?31,"|",?32,SSN,?46,"|"," FROM: ",$$FMTE^XLFDT(VFROM)," TO: ",$$FMTE^XLFDT(VTO),!,UL 47 W !,"(3) ADDRESS",?31,"|DATE OF ISSUE",?46,"| CONDITIONS FOR WHICH SERVICES ARE REQUESTED (DESCRIPTION OF DISABILITY)",!,?31,"|",?46,"|" 48 W !,FBI(1),?31,"|",?33,$$FMTE^XLFDT(FBJ),?46,"|"," ",VDX S FBPDX=0 49 I FBI(2)]"" W !,FBI(2),?31,"|",?46,"|"," " S FBPDX=FBPDX+1 W ?48,$P(FBDX,"^",FBPDX) 50 I FBI(3)]"" W !,FBI(3),?31,"|",?46,"|"," " S FBPDX=FBPDX+1 W ?48,$P(FBDX,"^",FBPDX) 51 W !,FBI(4)," ",PSTCD," ",FBI(6),?31,"|",?46,"|" S FBPDX=FBPDX+1 W ?48,$P(FBDX,"^",FBPDX),!,$E(UL,1,45),?46,"|" S FBPDX=FBPDX+1 W ?48,$P(FBDX,"^",FBPDX) 52 W !,"Name and Address of Fee Participant",?46,"|" S FBPDX=FBPDX+1 W ?48,$P(FBDX,"^",FBPDX) 53 W !,?46,"|",!,V(1),?46,"|",!,V(3),?46,"|" W:V(14)]"" !,V(14),?46,"|" 54 ; PRXM/KJH - Patch 103. Add Referring Provider and NPI to the display. 55 W !,V(4)," ",VSTCD," ",V(6),?46,"|","REFERRING PROVIDER: " 56 I REF'="" W $$GET1^DIQ(200,REF,.01) 57 W !,V(2),?46,"|","NPI: ",$$REFNPI^FBCH78(REF,"",1) 58 W !,?46,"|","AUTHORIZATION #: ",DFN,"-",FBK,!,UL,! 59 W ?49,"AUTHORIZATION REMARKS",!,?49,$E(UL,1,21) 60 D ^FBAA79A S $P(^FBAAA(DFN,1,FBK,1),"^",2)=DT,FBPG=1 Q 1 FBAA79 ;AISC/GRR-PRINT FORM 7079 REQUEST FOR OUTPATIENT MEDICAL SERVICES ;7/NOV/2006 2 ;;3.5;FEE BASIS;**12,23,101**;JAN 30, 1995;Build 2 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 W !,"Print 7079's for: " D DT^DICRW,DATE^FBAAUTL G:FBPOP END D SITEP^FBAAUTL G:FBPOP END 5 I '$D(^FBAAA("AF",2)) W !!,*7,"There are no 7079's to be printed!",! G END 6 S FBAASCR="" 7 RDHOW W ! S DIR("A")="Want only those that have not yet been printed",DIR("B")="Yes",DIR(0)="Y" D ^DIR K DIR G END:$D(DIRUT) S:Y FBAASCR="Y" 8 D OUTPUT^FBAAS79 9 S VAR="BEGDATE^ENDDATE^FBAASCR",VAL=BEGDATE_"^"_ENDDATE_"^"_FBAASCR,PGM="START^FBAA79",IOP="Q" D ZIS^FBAAUTL G:FBPOP END 10 START D SITEP^FBAAUTL G END:FBPOP 11 S UL="",ULL="----------",FBPG=0 F Z=1:1:12 S UL=UL_ULL 12 U IO S FBAASCR=$S(FBAASCR="":"I 1",FBAASCR="Y":"I $S('$D(^FBAAA(DFN,1,FBK,1)):1,$P(^FBAAA(DFN,1,FBK,1),""^"",2)']"""":1,1:0)",1:"I 1") 13 S FBJ=BEGDATE-.001,(DFN,FBK)=0 F ZZ=0:0 S FBJ=$O(^FBAAA("AF",2,FBJ)) Q:FBJ'>0!(FBJ>ENDDATE) F S DFN=$O(^FBAAA("AF",2,FBJ,DFN)) Q:DFN'>0 F S FBK=$O(^FBAAA("AF",2,FBJ,DFN,FBK)) Q:FBK'>0 X FBAASCR I D GOT 14 END K FBJ,FBK,DFN,Z,FBS,V,FBI,FBPATT,FBPG,FBSITE,UL,ULL,POV,NOV,POS,CC,PSTCD,SSTCD,VSTCD,BEGDATE,ENDDATE,PIDC,VDX,CODE,STATCD,D,FBAASCR,FBDX,FBIDC,FBOUT,FBPDX,FBREM,FBRR,NAME,PGM,POW,VAL,VAR,VFN,VFROM,VTO,YOB,ZZ 15 K FB7078,FBAABDT,FBAAEDT,FBASSOC,FBLOC,FBPOV,FBPSA,FBPT,FBTT,FBTYPE,FBVEN,FTP,CNT,FBAAOUT,FBAUT,FBPROG,I,J,M,PI,Q,SEX,SSN,TA,DATE,S,Y,DA,DIC 16 D CLOSE^FBAAUTL Q 17 Q 18 ; 19 ; Utilize new API for Name Standardization 20 ; 21 GOT Q:'$D(^DPT(DFN,0)) 22 S Y(0)=^DPT(DFN,0) 23 D 24 .N FBNAMES 25 .S FBNAMES("FILE")=2,FBNAMES("IENS")=DFN_",",FBNAMES("FIELD")=.01 26 .S NAME=$$NAMEFMT^XLFNAME(.FBNAMES) 27 S SEX=$P(Y(0),U,2) 28 S SSN=$TR($$SSNL4^FBAAUTL($$SSN^FBAAUTL(DFN)),"-",""),YOB=$S($P(Y(0),U,3)]"":$E($P(Y(0),U,3),1,3)+1700,1:""),POS=$S($D(^DPT(DFN,.32)):$P(^(.32),"^",3),1:""),POS=$S(POS]"":$P(^DIC(21,POS,0),"^",3),1:"") 29 F I=1:1:7 S FBI(I)="" 30 I $D(^DPT(DFN,.11)) F I=1:1:7 S FBI(I)=$P(^(.11),"^",I) 31 S POW=$P($G(^DPT(DFN,.52)),"^",5) 32 Q:'$D(^FBAAA(DFN,1,FBK)) S Y(0)=^(FBK,0),VFROM=$P(Y(0),"^",1),VTO=$P(Y(0),"^",2),VFN=$P(Y(0),"^",4) I $S($P(Y(0),"^",3)=6:1,$P(Y(0),"^",3)=7:1,1:"") Q 33 S VDX=$P(Y(0),"^",8),FBPATT=$P(Y(0),"^",18),POV=$$EXTPV^FBAAUTL5($P(Y(0),"^",7)),CODE=$P(Y(0),"^",13),PIDC=$P(Y(0),"^",12),NOV=$P($G(^FBAAA(DFN,1,FBK,1)),"^") 34 S FBDX=$G(^FBAAA(DFN,1,FBK,3)) 35 S FBIDC=$P($G(^FBAAA(DFN,4)),"^") 36 S STATCD=FBI(5),CC=FBI(7) F V=1:1:14 S V(V)="" 37 S CC=$S(CC']"":"",$D(^DIC(5,+STATCD,1,CC,0)):$P(^(0),"^",3),1:"") 38 S Y(0)=$S(VFN']"":"",'$D(^FBAAV(VFN,0)):"",$D(^FBAAV(VFN,0)):^(0),1:"") G:$S(VFN']"":1,'$D(^FBAAV(VFN,0)):1,1:0) OVR 39 F V=2,1,3,14,4,5,6,10 S V(V)=$P(Y(0),"^",V) 40 OVR F S=1:1:9 S FBS(S)=$P(FBSITE(0),"^",S) 41 S VSTCD=$S(V(5)']"":" ",$D(^DIC(5,V(5),0)):$P(^(0),"^",2),1:" "),SSTCD=$S(FBS(5)']"":" ",$D(^DIC(5,+FBS(5),0)):$P(^(0),"^",2),1:" "),PSTCD=$S(FBI(5)']"":" ",$D(^DIC(5,+FBI(5),0)):$P(^(0),"^",2),1:" ") 42 W:FBPG @IOF W UL,!,?46,"Department of Veterans Affairs",?100,"ID Card Number: ",FBIDC,!,?35,"R E Q U E S T F O R O U T P A T I E N T S E R V I C E S",!,UL S FBREM=0,FBOUT=0 43 ; 44 W !,"(1) Veterans Name",?31,"|(2) ID Number | Period of Validity",!,?31,"|",?46,"|" 45 W !,NAME,?31,"|",?32,SSN,?46,"|"," FROM: ",$$FMTE^XLFDT(VFROM)," TO: ",$$FMTE^XLFDT(VTO),!,UL 46 W !,"(3) ADDRESS",?31,"|DATE OF ISSUE",?46,"| CONDITIONS FOR WHICH SERVICES ARE REQUESTED (DESCRIPTION OF DISABILITY)",!,?31,"|",?46,"|" 47 W !,FBI(1),?31,"|",?33,$$FMTE^XLFDT(FBJ),?46,"|"," ",VDX S FBPDX=0 48 I FBI(2)]"" W !,FBI(2),?31,"|",?46,"|"," " S FBPDX=FBPDX+1 W ?48,$P(FBDX,"^",FBPDX) 49 I FBI(3)]"" W !,FBI(3),?31,"|",?46,"|"," " S FBPDX=FBPDX+1 W ?48,$P(FBDX,"^",FBPDX) 50 W !,FBI(4)," ",PSTCD," ",FBI(6),?31,"|",?46,"|" S FBPDX=FBPDX+1 W ?48,$P(FBDX,"^",FBPDX),!,$E(UL,1,45),?46,"|" S FBPDX=FBPDX+1 W ?48,$P(FBDX,"^",FBPDX) 51 W !,"Name and Address of Fee Participant",?46,"|" S FBPDX=FBPDX+1 W ?48,$P(FBDX,"^",FBPDX) 52 W !,?46,"|",!,V(1),?46,"|",!,V(3),?46,"|" W:V(14)]"" !,V(14),?46,"|" 53 W !,V(4)," ",VSTCD," ",V(6),?46,"|",!,V(2),?46,"|","AUTHORIZATION #: ",DFN,"-",FBK,!,UL,! 54 W ?49,"AUTHORIZATION REMARKS",!,?49,$E(UL,1,21) 55 D ^FBAA79A S $P(^FBAAA(DFN,1,FBK,1),"^",2)=DT,FBPG=1 Q -
WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBAA79A.m
r613 r623 1 FBAA79A ;AISC/GRR-PRINT 7079 CONTINUED ;1/12/98 2 ;;3.5;FEE BASIS;**12,103**;JAN 30, 1995;Build 19 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 S DIWL=1,DIWF="WC120" K ^UTILITY($J,"W") 5 I $D(^FBAAA(DFN,1,FBK,2)) F FBRR=0:0 S FBRR=$O(^FBAAA(DFN,1,FBK,2,FBRR)) Q:FBRR'>0 S FBXX=^(FBRR,0),X=FBXX D ^DIWP 6 D ^DIWW:$D(FBXX) K FBXX 7 W !,?40,"FOR VA USE ONLY",!,UL 8 W !," (5) STATE CODE | (6) COUNTY CODE | (7) TYPE OF | (8) YEAR OF BIRTH | (9) WAR | (10) PURPOSE |",!,?16,"|",?34,"|",?37,"PATIENT",?48,"|",?68,"|",?78,"|",?93,"|" 9 W !,?7,FBI(5),?16,"|",?23,CC,?34,"|",?41,FBPATT,?48,"|",?58,YOB,?68,"|",?74,POS,?78,"|",?87,POV,?93,"|",!,UL 10 W !,"STATION OF JURISDICTION",?48,"|",?78,"|",?80," (11) CODE",?100,"| (12) SEX",!,?48,"|",?78,"|",?100,"|"," ",$S(SEX="F":"FEMALE",1:"MALE") 11 W !,"Veterans Administration",?48,"|",?78,"|",?100,"|",$E(UL,101,120) 12 W !,FBS(2),?48,"|",?78,"|",?80,$S(CODE=1:"SHORT TERM - 1",CODE=2:"HOME NURSING - 2",CODE=3:"ID CARD STATUS - 3",1:""),?100,"| (13) POW" 13 W:FBS(3)]"" !,FBS(3),?48,"|",?78,"|",?100,"|"," ",$S(POW="Y":"YES",1:"NO") 14 W !,FBS(4)," ",SSTCD," ",FBS(6),?48,"|",?78,"|",?100,"|" W:FBS(3)']"" " ",$S(POW="Y":"YES",1:"NO") W !,?48,$E(UL,49,120) 15 W !,?48,"| APPROVED BY (Name and Title)",?110,"(",$S($D(^VA(200,DUZ,0)):$P(^(0),"^",2),1:""),")",!,?48,"|" 16 W !,"TELEPHONE: ",FBS(7),?48,"|",?50,FBS(8),!,?48,"|",?50,FBS(9),!,UL 17 W !,?32,"Information On Veterans Administration Program",! 18 W !,"Acceptance of this request to render the prescribed services will constitute an agreement which is subject",!,"to the following: ",! 19 W !,?3,"I. SERVICES. If services are not initiated, please return this document to the Station of Jurisdiction with a brief" 20 W !,?5,"explanation. Unless approved by the VA, services are limited in type and extent to those shown.",! 21 W !,?3,"II. PERIOD OF VALIDITY. Service must be performed within the period of validity indicated.",!,?5,"If a longer time is needed, please request an extension.",! 22 W !,?3,"III. REPORTS. Clinical reports are required when an examination only has been requested. Please ",!,?5,"submit reports promptly to the Station Of Jurisdiction.",! 23 W !,?3,"IV. STATEMENT OF ACCOUNTS. Submit a Statement of Account in your usual manner. Your statement must",!,?5,"include: (1) Patient's Name; (2) Identification NO.; (3) Treatment (CPT) and Dates Rendered; and (4) Fees.",! 24 W !,?3,"V. FEES. Fees claimed may not exceed those made to the general public for like services.",! 25 W !,?3,"VI. PAYMENT. Payment by the VA for services rendered and approved is payment in full.",! 26 W !,?3,"VII. HOSPITALIZATION. When a need for hospital care is indicated, please call the Station of Jurisdiction",!,?5,"for assistance in admitting the veteran to a VA hospital.",! 27 W !,?3,"VIII. INQUIRIES. Additional information when required may be obtained by contacting the Station Of Jurisdiction.",! 28 W !,?3,"IX. When submitting claims for payment you must include the NPI and Taxonomy Code of the rendering practitioner, and" 29 W !,?5,"the NPI and Taxonomy Code of your organization. If, under the HIPAA NPI Final Rule" 30 W !,?5,"[http://www.cms.hhs.gov/NationalProvIdentStand], your organization is an ""atypical"" provider furnishing services such as" 31 W !,?5,"taxi, home and vehicle modifications, insect control, habilitation, and respite services and is therefore ineligible" 32 W !,?5,"for an NPI, it is important that you indicate ""Ineligible for NPI"" on your claim form ." 33 W !,UL 34 W !?3,"VA Form 10-7079" 35 W ?85,"Date Printed: ",$$FMTE^XLFDT(DT),! 36 Q 1 FBAA79A ;AISC/GRR-PRINT 7079 CONTINUED ;1/12/98 2 ;;3.5;FEE BASIS;**12**;JAN 30, 1995 3 ;;Per VHA Directive 10-93-142, this routine should not be modified. 4 S DIWL=1,DIWF="WC120" K ^UTILITY($J,"W") 5 I $D(^FBAAA(DFN,1,FBK,2)) F FBRR=0:0 S FBRR=$O(^FBAAA(DFN,1,FBK,2,FBRR)) Q:FBRR'>0 S FBXX=^(FBRR,0),X=FBXX D ^DIWP 6 D ^DIWW:$D(FBXX) K FBXX 7 W !,?40,"FOR VA USE ONLY",!,UL 8 W !," (5) STATE CODE | (6) COUNTY CODE | (7) TYPE OF | (8) YEAR OF BIRTH | (9) WAR | (10) PURPOSE |",!,?16,"|",?34,"|",?37,"PATIENT",?48,"|",?68,"|",?78,"|",?93,"|" 9 W !,?7,FBI(5),?16,"|",?23,CC,?34,"|",?41,FBPATT,?48,"|",?58,YOB,?68,"|",?74,POS,?78,"|",?87,POV,?93,"|",!,UL 10 W !,"STATION OF JURISDICTION",?48,"|",?78,"|",?80," (11) CODE",?100,"| (12) SEX",!,?48,"|",?78,"|",?100,"|"," ",$S(SEX="F":"FEMALE",1:"MALE") 11 W !,"Veterans Administration",?48,"|",?78,"|",?100,"|",$E(UL,101,120) 12 W !,FBS(2),?48,"|",?78,"|",?80,$S(CODE=1:"SHORT TERM - 1",CODE=2:"HOME NURSING - 2",CODE=3:"ID CARD STATUS - 3",1:""),?100,"| (13) POW" 13 W:FBS(3)]"" !,FBS(3),?48,"|",?78,"|",?100,"|"," ",$S(POW="Y":"YES",1:"NO") 14 W !,FBS(4)," ",SSTCD," ",FBS(6),?48,"|",?78,"|",?100,"|" W:FBS(3)']"" " ",$S(POW="Y":"YES",1:"NO") W !,?48,$E(UL,49,120) 15 W !,?48,"| APPROVED BY (Name and Title)",?110,"(",$S($D(^VA(200,DUZ,0)):$P(^(0),"^",2),1:""),")",!,?48,"|" 16 W !,"TELEPHONE: ",FBS(7),?48,"|",?50,FBS(8),!,?48,"|",?50,FBS(9),!,UL 17 W !,?32,"Information On Veterans Administration Program",! 18 W !,"Acceptance of this request to render the prescribed services will constitute an agreement which is subject",!,"to the following: ",! 19 W !,?3,"I. SERVICES. If services are not initiated, please return this document to the Station of Jurisdiction with a brief" 20 W !,?5,"explanation. Unless approved by the VA, services are limited in type and extent to those shown.",! 21 W !,?3,"II. PERIOD OF VALIDITY. Service must be performed within the period of validity indicated.",!,?5,"If a longer time is needed, please request an extension.",! 22 W !,?3,"III. REPORTS. Clinical reports are required when an examination only has been requested. Please ",!,?5,"submit reports promptly to the Station Of Jurisdiction.",! 23 W !,?3,"IV. STATEMENT OF ACCOUNTS. Submit a Statement of Account in your usual manner. Your statement must",!,?5,"include: (1) Patient's Name; (2) Identification NO.; (3) Treatment (CPT) and Dates Rendered; and (4) Fees.",! 24 W !,?3,"V. FEES. Fees claimed may not exceed those made to the general public for like services.",! 25 W !,?3,"VI. PAYMENT. Payment by the VA for services rendered and approved is payment in full.",! 26 W !,?3,"VII. HOSPITALIZATION. When a need for hospital care is indicated, please call the Station of Jurisdiction",!,?5,"for assistance in admitting the veteran to a VA hospital.",! 27 W !,?3,"VIII. INQUIRIES. Additional information when required may be obtained by contacting the Station Of Jurisdiction.",!,UL 28 W !?3,"VA Form 10-7079" 29 W ?85,"Date Printed: ",$$FMTE^XLFDT(DT),! 30 Q -
WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBAAAUT.m
r613 r623 1 FBAAAUT ;AISC/DMK - ENTER/EDIT AUTHORIZATION ;3/11/1999 2 ;;3.5;FEE BASIS;**13,95,103**;JAN 30, 1995;Build 19 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 D SITEP^FBAAUTL G Q:FBPOP S FBAADDYS=+$P(FBSITE(0),"^",13),FBAAASKV=$P(FBSITE(1),"^",1),FBPROG=$S($P(FBSITE(1),"^",6)="":"I 1",1:"I $P(^(0),U,3)=2") 5 W ! S DIC="^DPT(",DIC(0)="QEAZM" D ^DIC G Q:Y<0 S DFN=+Y 6 I $P($G(^DPT(DFN,.361)),"^")="" W !!,"ELIGIBILITY HAS NOT BEEN DETERMINED NOR PENDING, CANNOT ENTER AN AUTHORIZATION." G FBAAAUT 7 CONT I $P($G(^DPT(DFN,.32)),"^",4)=2 W !!?4,"VETERAN HAS A DISHONORABLE DISCHARGE, " S X=$P($G(^(.321)),"^") W $S(X="Y":"ONLY ELIGIBLE FOR AGENT ORANGE EXAM.",1:"NOT ELIGIBLE FOR BENEFITS.") 8 W ! S DIR("A")="Do you want to continue",DIR(0)="Y",DIR("B")="Yes" D ^DIR K DIR G FBAAAUT:$S($D(DIRUT):1,'Y:1,1:0) 9 1 S DA=DFN I '$D(^FBAAA(DA,0)) L +^FBAAA(DA) K DD,DO S (X,DINUM)=DA,DIC="^FBAAA(",DIC(0)="LM",DLAYGO=161 D FILE^DICN L -^FBAAA(DFN) K DIC G:Y<0 Q 10 S:'$D(^FBAAA(DFN,1,0)) ^(0)="^161.01D^^" 11 D ^FBAADEM K DIRUT,DIROUT,DTOUT,DUOUT 12 2 W ! S (HID,NID,FBAAP79,FBANEW)="",DA=DFN,DIE="^FBAAA(",DIE("NO^")="",DR="[FBAA AUTHORIZATION]" D ^DIE I $D(FBD1) S FBANEW=$G(^FBAAA(DFN,1,FBD1,0)) 13 D:'$D(Y)&(HID'="")&(HID'=NID) TRIG K HID,NID,NIDR,TIME G FBAAAUT:FBANEW']"" S X=FBANEW,K=FBD1,J=DT 14 I FBAAP79="Y" S $P(^FBAAA(DFN,1,FBD1,1),"^",2)="",FBDFN=DFN D CHEKP79 S DFN=FBDFN 15 I $D(FBAOLD),FBAOLD'=FBANEW,$D(FBAALT),FBAALT="Y" S FBTTYPE="A",FBMST=$S($P(FBANEW,"^",13)=1:"Y",1:""),FBFDC=$S($P(FBAOLD,"^")'=$P(FBANEW,"^"):1,1:"") D MORE 16 I '$D(^FBAAC(DFN,0)) K DD,DO S (X,DINUM)=DFN,DIC(0)="L",DLAYGO=162,DIC="^FBAAC(" D FILE^DICN K DIC,DLAYGO 17 G FBAAAUT 18 TRIG ;Add an entry in Fee Basis ID Card Audit file 19 I '$D(^FBAA(161.83,DFN)) K DD,DO S (X,DINUM)=DFN,DIC="^FBAA(161.83,",DIC(0)="L",DLAYGO=161.83 D FILE^DICN Q:Y<0 20 S:'$D(^FBAA(161.83,DFN,1,0)) ^(0)="^161.831DA^^" 21 S %DT="XT",X="NOW" D ^%DT K %DT S TIME=Y 22 L +^FBAA(161.83,DFN) S DIC="^FBAA(161.83,"_DFN_",1,",DIC(0)="LM",DINUM=9999999.9999-TIME,X=TIME,DIC("DR")="1////^S X=HID;2////^S X=NIDR;3////^S X=DUZ",DA(1)=DFN K DD,DO D FILE^DICN I Y<0 L -^FBAA(161.83,DFN) Q 23 K DIE,DIC,DA,DLAYGO L -^FBAA(161.83,DFN) 24 Q 25 ENT ;ENTRY POINT FROM ^FBAAPM TO CREATE MRA TRANSACTION 26 MORE ; 27 S DIC="^FBAA(161.26,",DIC(0)="L",DLAYGO=161.26,X=DFN 28 S DIC("DR")="1///^S X=""P"";2///^S X=FBD1;3///^S X=FBTTYPE;5////^S X=FBFDC;6////^S X=FBMST" 29 K DD,DO D FILE^DICN K DIC,DLAYGO S DA=+Y 30 Q 31 ; 32 CHEKP79 W ! S DIR("A")="Want to Print 7079 for this patient now",DIR(0)="Y",DIR("B")="No" D ^DIR K DIR I Y S FBK=FBD1 D EN1^FBAAS79 33 Q 34 Q K DA,DAT,DFN,DR,F,FBAASKV,FBAADDYS,FBAALT,FBAAP79,FBAATT,FBANEW,FBAOLD,FBCOUNTY,FBDX,FBI,FBRR,FBSITE,FBTYPE,FBXX,I,J,K,PI,S,T,Z,ZZ,FBAAASKV,FBPROG,DIC,DIE,FBAAX,X,Y,PTYPE,FBPRG,FBAAOUT,FBDFN 35 K FBAUT,FBD1,FBPOP 36 Q 37 ; 38 ; PROVIDER LOOKUP 39 ; 40 ; This function checks the inputed File 200 entry to ensure that it has been assigned the Security Key PROVIDER. 41 ; 42 ; Referenced: AUTHORIZATION Sub-File (#161.01) OF FEE BASIS PATIENT File (#161) - REFERRING PROVIDER Field (#104) 43 ; Referenced: FEE NOTIFICATION/REQUEST File (#162.2) - REFERRING PROVIDER Field (#17) 44 ; Referenced: VA FORM 10-7078 File (#162.4) - REFERRING PROVIDER Field (#15) 45 ; 46 ; Input - FB200IEN - Internal IEN of file 200 entry 47 ; Output - 0 Blank Input or entry without PROVIDER Security Key 48 ; - 1 Entry PROVIDER Security Key assigned 49 ; 50 PROVIDER(FB200IEN) N Y 51 ; 52 Q:$G(FB200IEN)="" 0 53 ; 54 ;Test for PROVIDER Security Key 55 I $D(^XUSEC("PROVIDER",FB200IEN)) Q 1 56 ; 57 ;Entry did not have PROVIDER Security Key 58 Q 0 1 FBAAAUT ;AISC/DMK-ENTER/EDIT AUTHORIZATION ;3/11/1999 2 ;;3.5;FEE BASIS;**13,95**;JAN 30, 1995 3 ;;Per VHA Directive 10-93-142, this routine should not be modified. 4 D SITEP^FBAAUTL G Q:FBPOP S FBAADDYS=+$P(FBSITE(0),"^",13),FBAAASKV=$P(FBSITE(1),"^",1),FBPROG=$S($P(FBSITE(1),"^",6)="":"I 1",1:"I $P(^(0),U,3)=2") 5 W ! S DIC="^DPT(",DIC(0)="QEAZM" D ^DIC G Q:Y<0 S DFN=+Y 6 I $P($G(^DPT(DFN,.361)),"^")="" W !!,"ELIGIBILITY HAS NOT BEEN DETERMINED NOR PENDING, CANNOT ENTER AN AUTHORIZATION." G FBAAAUT 7 CONT I $P($G(^DPT(DFN,.32)),"^",4)=2 W !!?4,"VETERAN HAS A DISHONORABLE DISCHARGE, " S X=$P($G(^(.321)),"^") W $S(X="Y":"ONLY ELIGIBLE FOR AGENT ORANGE EXAM.",1:"NOT ELIGIBLE FOR BENEFITS.") 8 W ! S DIR("A")="Do you want to continue",DIR(0)="Y",DIR("B")="Yes" D ^DIR K DIR G FBAAAUT:$S($D(DIRUT):1,'Y:1,1:0) 9 1 S DA=DFN I '$D(^FBAAA(DA,0)) L +^FBAAA(DA) K DD,DO S (X,DINUM)=DA,DIC="^FBAAA(",DIC(0)="LM",DLAYGO=161 D FILE^DICN L -^FBAAA(DFN) K DIC G:Y<0 Q 10 S:'$D(^FBAAA(DFN,1,0)) ^(0)="^161.01D^^" 11 D ^FBAADEM K DIRUT,DIROUT,DTOUT,DUOUT 12 2 W ! S (HID,NID,FBAAP79,FBANEW)="",DA=DFN,DIE="^FBAAA(",DIE("NO^")="",DR="[FBAA AUTHORIZATION]" D ^DIE I $D(FBD1) S FBANEW=$G(^FBAAA(DFN,1,FBD1,0)) 13 D:'$D(Y)&(HID'="")&(HID'=NID) TRIG K HID,NID,NIDR,TIME G FBAAAUT:FBANEW']"" S X=FBANEW,K=FBD1,J=DT 14 I FBAAP79="Y" S $P(^FBAAA(DFN,1,FBD1,1),"^",2)="",FBDFN=DFN D CHEKP79 S DFN=FBDFN 15 I $D(FBAOLD),FBAOLD'=FBANEW,$D(FBAALT),FBAALT="Y" S FBTTYPE="A",FBMST=$S($P(FBANEW,"^",13)=1:"Y",1:""),FBFDC=$S($P(FBAOLD,"^")'=$P(FBANEW,"^"):1,1:"") D MORE 16 I '$D(^FBAAC(DFN,0)) K DD,DO S (X,DINUM)=DFN,DIC(0)="L",DLAYGO=162,DIC="^FBAAC(" D FILE^DICN K DIC,DLAYGO 17 G FBAAAUT 18 TRIG ;Add an entry in Fee Basis ID Card Audit file 19 I '$D(^FBAA(161.83,DFN)) K DD,DO S (X,DINUM)=DFN,DIC="^FBAA(161.83,",DIC(0)="L",DLAYGO=161.83 D FILE^DICN Q:Y<0 20 S:'$D(^FBAA(161.83,DFN,1,0)) ^(0)="^161.831DA^^" 21 S %DT="XT",X="NOW" D ^%DT K %DT S TIME=Y 22 L +^FBAA(161.83,DFN) S DIC="^FBAA(161.83,"_DFN_",1,",DIC(0)="LM",DINUM=9999999.9999-TIME,X=TIME,DIC("DR")="1////^S X=HID;2////^S X=NIDR;3////^S X=DUZ",DA(1)=DFN K DD,DO D FILE^DICN I Y<0 L -^FBAA(161.83,DFN) Q 23 K DIE,DIC,DA,DLAYGO L -^FBAA(161.83,DFN) 24 Q 25 ENT ;ENTRY POINT FROM ^FBAAPM TO CREATE MRA TRANSACTION 26 MORE ; 27 S DIC="^FBAA(161.26,",DIC(0)="L",DLAYGO=161.26,X=DFN 28 S DIC("DR")="1///^S X=""P"";2///^S X=FBD1;3///^S X=FBTTYPE;5////^S X=FBFDC;6////^S X=FBMST" 29 K DD,DO D FILE^DICN K DIC,DLAYGO S DA=+Y 30 Q 31 ; 32 CHEKP79 W ! S DIR("A")="Want to Print 7079 for this patient now",DIR(0)="Y",DIR("B")="No" D ^DIR K DIR I Y S FBK=FBD1 D EN1^FBAAS79 33 Q 34 Q K DA,DAT,DFN,DR,F,FBAASKV,FBAADDYS,FBAALT,FBAAP79,FBAATT,FBANEW,FBAOLD,FBCOUNTY,FBDX,FBI,FBRR,FBSITE,FBTYPE,FBXX,I,J,K,PI,S,T,Z,ZZ,FBAAASKV,FBPROG,DIC,DIE,FBAAX,X,Y,PTYPE,FBPRG,FBAAOUT,FBDFN 35 K FBAUT,FBD1,FBPOP 36 Q -
WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBAADEM1.m
r613 r623 1 FBAADEM1 ;AISC/DMK-DISPLAY PATIENT DEMOGRAPHICS ;14MAY92 2 ;;3.5;FEE BASIS;**13,51,103**;JAN 30, 1995;Build 19 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 EN N FBDX,FBFDT,FBI,FBRR,FBT,FBTYPE,FBV,FBZ,PSA 5 S:'$D(FBPROG) FBPROG="I 1" 6 ; 7 S Y=$G(^FBAAA(DFN,4)) W:$P(Y,"^")]"" !,"Fee ID Card #: ",$P(Y,"^"),?40,"Fee Card Issue Date: " S Y=$P(Y,"^",2) D PDF W Y,! 8 ; 9 I $O(^FBAAA(DFN,1,0)) D Q:FBAAOUT 10 . D HANG:$Y+5>IOSL Q:FBAAOUT 11 . W !,"Patient Name: ",VADM(1),?55,"Pt.ID: ",$P(VADM(2),"^",2) 12 . W !!,"AUTHORIZATIONS:",! 13 . K FBAUT 14 . S FBZ=0,FBFDT="9999999" 15 . F S FBFDT=$O(^FBAAA(DFN,1,"B",FBFDT),-1) Q:'FBFDT D Q:FBAAOUT 16 . . S FBI=0 F S FBI=$O(^FBAAA(DFN,1,"B",FBFDT,FBI)) Q:'FBI I $D(^FBAAA(DFN,1,FBI,0)) X FBPROG I S FBZ=FBZ+1,X=^(0) D Q:FBAAOUT 17 . . . S Y=+X,PSA=$P(X,"^",5),FBT=$P(X,"^",13),FBV=+$P(X,"^",4) D PDF 18 . . . W ?3,"(",FBZ,")",?7,"FR: ",Y,?25,"VENDOR: ",$S($D(^FBAAV(FBV,0)):$P(^(0),"^")_" - "_$P(^(0),"^",2),1:"Not Specified") 19 . . . S FBDX=$G(^FBAAA(DFN,1,FBI,3)) W !?7,"TO: " S Y=$P(X,"^",2) D PDF W Y,!?25,"Authorization Type: " D 20 . . . . S FBTYPE=$P(X,"^",3),FBTYPE=$S(FBTYPE=2:"Outpatient - "_$S(FBT=1:"Short Term",FBT=2:"Home Health",FBT=3:"ID Card",1:""),$D(^FBAA(161.8,+FBTYPE,0)):$P(^(0),"^"),1:"Unknown") 21 . . . W FBTYPE W:$P(X,"^",7) !,?11,"Purpose of Visit: ",$P($G(^FBAA(161.82,$P(X,"^",7),0)),"^") I $P(X,"^",9)["FB583(" W !?25,">> Unauthorized Claim <<" 22 . . . ; PRXM/KJH - Patch 103. Add Referring Provider and NPI to the display. 23 . . . W !?11,"DX: ",$P(X,"^",8) W ?40,"REF: " 24 . . . I $P(X,"^",21)'="" W $$GET1^DIQ(200,$P(X,"^",21),.01) 25 . . . W !?11,"REF NPI: ",$$REFNPI^FBCH78($P(X,"^",21)),! 26 . . . W:$P(FBDX,"^")]"" !?15,$P(FBDX,"^") W:$P(FBDX,"^",2)]"" !?15,$P(FBDX,"^",2) 27 . . . S FBAUT($P(X,"^"))=$P(X,"^",2) 28 . . . W !?7,"County: ",FBCOUNTY,?40,"PSA: ",$S($D(^DIC(4,+PSA,0)):$P(^(0),"^"),1:"Unknown"),! 29 . . . S FBDEL=$G(^FBAAA(DFN,1,FBI,"ADEL")) I FBDEL]"" S Y=$P(FBDEL,"^",2) D PDF W ?12,">> DELETE MRA SENT TO AUSTIN ON - ",Y," >>",! 30 . . . I $D(^FBAAA(DFN,1,FBI,2,0)) K ^UTILITY($J,"W") S DIWL=15,DIWR=70,DIWF="W" D HANG:$Y+6>IOSL Q:FBAAOUT W !?11,"REMARKS:" D 31 . . . . S FBRR=0 F S FBRR=$O(^FBAAA(DFN,1,FBI,2,FBRR)) Q:'FBRR S (FBXX,X)=^(FBRR,0) D ^DIWP 32 . . . D ^DIWW:$D(FBXX) K FBXX W ! 33 . . . K X,FBDX,FBT,FBTYPE,FBV,PSA D HANG:$Y+5>IOSL 34 ; 35 D HANG:$Y+5>IOSL Q:FBAAOUT 36 ; 37 I $O(^FBAAA(DFN,2,0))>0 D Q:FBAAOUT 38 . W !,"VENDOR CONTACTS:" 39 . S (FBZ,FBI)=0 40 . F S FBI=$O(^FBAAA(DFN,2,FBI)) Q:'FBI!(FBAAOUT) S FBZ=FBZ+1,X=$G(^(FBI,0)),Y=+X D PDF D 41 . . W !?3,"(",FBZ,")",?7,"DATE: ",Y,?25,"VENDOR: ",$P(X,"^",2),?55,"PHONE: ",$S($P(X,"^",3)]"":$P(X,"^",3),1:"Not Found") 42 . . I $D(^FBAAA(DFN,2,FBI,1,0)) K ^UTILITY($J,"W") S DIWL=20,DIWR=70,DIWF="W" D HANG:$Y+5>IOSL Q:FBAAOUT W !?11,"NARRATIVE:",! D 43 . . . S FBRR=0 F S FBRR=$O(^FBAAA(DFN,2,FBI,1,FBRR)) Q:'FBRR S FBXX=^(FBRR,0) D HANG:$Y+5>IOSL Q:FBAAOUT S X=FBXX D ^DIWP 44 . . D ^DIWW:$D(FBXX) K FBXX W ! 45 Q 46 ; 47 HANG I $E(IOST,1,2)="C-" S DIR(0)="E" D ^DIR K DIR S:'Y FBAAOUT=1 48 W @IOF I 'FBAAOUT W !,"Patient Name: ",VADM(1),?55,"Pt.ID: ",$P(VADM(2),"^",2),! 49 Q 50 ; 51 PDF S:Y Y=$$FMTE^XLFDT(Y,5) ; TRANSLATE TO DISPLAY DATE 52 Q 1 FBAADEM1 ;AISC/DMK-DISPLAY PATIENT DEMOGRAPHICS ;14MAY92 2 ;;3.5;FEE BASIS;**13,51**;JAN 30, 1995 3 ;;Per VHA Directive 10-93-142, this routine should not be modified. 4 EN N FBDX,FBFDT,FBI,FBRR,FBT,FBTYPE,FBV,FBZ,PSA 5 S:'$D(FBPROG) FBPROG="I 1" 6 ; 7 S Y=$G(^FBAAA(DFN,4)) W:$P(Y,"^")]"" !,"Fee ID Card #: ",$P(Y,"^"),?40,"Fee Card Issue Date: " S Y=$P(Y,"^",2) D PDF W Y,! 8 ; 9 I $O(^FBAAA(DFN,1,0)) D Q:FBAAOUT 10 . D HANG:$Y+5>IOSL Q:FBAAOUT 11 . W !,"Patient Name: ",VADM(1),?55,"Pt.ID: ",$P(VADM(2),"^",2) 12 . W !!,"AUTHORIZATIONS:",! 13 . K FBAUT 14 . S FBZ=0,FBFDT="9999999" 15 . F S FBFDT=$O(^FBAAA(DFN,1,"B",FBFDT),-1) Q:'FBFDT D Q:FBAAOUT 16 . . S FBI=0 F S FBI=$O(^FBAAA(DFN,1,"B",FBFDT,FBI)) Q:'FBI I $D(^FBAAA(DFN,1,FBI,0)) X FBPROG I S FBZ=FBZ+1,X=^(0) D Q:FBAAOUT 17 . . . S Y=+X,PSA=$P(X,"^",5),FBT=$P(X,"^",13),FBV=+$P(X,"^",4) D PDF 18 . . . W ?3,"(",FBZ,")",?7,"FR: ",Y,?25,"VENDOR: ",$S($D(^FBAAV(FBV,0)):$P(^(0),"^")_" - "_$P(^(0),"^",2),1:"Not Specified") 19 . . . S FBDX=$G(^FBAAA(DFN,1,FBI,3)) W !?7,"TO: " S Y=$P(X,"^",2) D PDF W Y,!?25,"Authorization Type: " D 20 . . . . S FBTYPE=$P(X,"^",3),FBTYPE=$S(FBTYPE=2:"Outpatient - "_$S(FBT=1:"Short Term",FBT=2:"Home Health",FBT=3:"ID Card",1:""),$D(^FBAA(161.8,+FBTYPE,0)):$P(^(0),"^"),1:"Unknown") 21 . . . W FBTYPE W:$P(X,"^",7) !,?11,"Purpose of Visit: ",$P($G(^FBAA(161.82,$P(X,"^",7),0)),"^") I $P(X,"^",9)["FB583(" W !?25,">> Unauthorized Claim <<" 22 . . . W !?11,"DX: ",$P(X,"^",8) W:$P(FBDX,"^")]"" !?15,$P(FBDX,"^") W:$P(FBDX,"^",2)]"" !?15,$P(FBDX,"^",2) 23 . . . S FBAUT($P(X,"^"))=$P(X,"^",2) 24 . . . W !?7,"County: ",FBCOUNTY,?40,"PSA: ",$S($D(^DIC(4,+PSA,0)):$P(^(0),"^"),1:"Unknown"),! 25 . . . S FBDEL=$G(^FBAAA(DFN,1,FBI,"ADEL")) I FBDEL]"" S Y=$P(FBDEL,"^",2) D PDF W ?12,">> DELETE MRA SENT TO AUSTIN ON - ",Y," >>",! 26 . . . I $D(^FBAAA(DFN,1,FBI,2,0)) K ^UTILITY($J,"W") S DIWL=15,DIWR=70,DIWF="W" D HANG:$Y+6>IOSL Q:FBAAOUT W !?11,"REMARKS:" D 27 . . . . S FBRR=0 F S FBRR=$O(^FBAAA(DFN,1,FBI,2,FBRR)) Q:'FBRR S (FBXX,X)=^(FBRR,0) D ^DIWP 28 . . . D ^DIWW:$D(FBXX) K FBXX W ! 29 . . . K X,FBDX,FBT,FBTYPE,FBV,PSA D HANG:$Y+5>IOSL 30 ; 31 D HANG:$Y+5>IOSL Q:FBAAOUT 32 ; 33 I $O(^FBAAA(DFN,2,0))>0 D Q:FBAAOUT 34 . W !,"VENDOR CONTACTS:" 35 . S (FBZ,FBI)=0 36 . F S FBI=$O(^FBAAA(DFN,2,FBI)) Q:'FBI!(FBAAOUT) S FBZ=FBZ+1,X=$G(^(FBI,0)),Y=+X D PDF D 37 . . W !?3,"(",FBZ,")",?7,"DATE: ",Y,?25,"VENDOR: ",$P(X,"^",2),?55,"PHONE: ",$S($P(X,"^",3)]"":$P(X,"^",3),1:"Not Found") 38 . . I $D(^FBAAA(DFN,2,FBI,1,0)) K ^UTILITY($J,"W") S DIWL=20,DIWR=70,DIWF="W" D HANG:$Y+5>IOSL Q:FBAAOUT W !?11,"NARRATIVE:",! D 39 . . . S FBRR=0 F S FBRR=$O(^FBAAA(DFN,2,FBI,1,FBRR)) Q:'FBRR S FBXX=^(FBRR,0) D HANG:$Y+5>IOSL Q:FBAAOUT S X=FBXX D ^DIWP 40 . . D ^DIWW:$D(FBXX) K FBXX W ! 41 Q 42 ; 43 HANG I $E(IOST,1,2)="C-" S DIR(0)="E" D ^DIR K DIR S:'Y FBAAOUT=1 44 W @IOF I 'FBAAOUT W !,"Patient Name: ",VADM(1),?55,"Pt.ID: ",$P(VADM(2),"^",2),! 45 Q 46 ; 47 PDF S:Y Y=$$FMTE^XLFDT(Y,5) ; TRANSLATE TO DISPLAY DATE 48 Q -
WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBAAFSR.m
r613 r623 1 FBAAFSR ;WCIOFO/TCK,SS,DMK,SAB-RBRVS FEE SCHEDULE ; 8/26/1999 2 ;;3.5;FEE BASIS;**4,53,71,84,92,93,99,102,105**;JAN 30, 1995;Build 1 3 ; 4 Q 5 ; 6 RBRVS(CPT,MODL,DOS,ZIP,FAC,TIME) ; calculate RBRVS Fee Schedule amount 7 ; Input 8 ; CPT = CPT/HCPCS code (external value) 9 ; MODL = list of CPT/HCPCS modifiers (external values) 10 ; delimited by commas (e.g. "26,51") 11 ; DOS = date of service (fileman format e.g. 2980101) 12 ; ZIP = ZIP code of service (external 5 digit value) 13 ; FAC = facility flag =1 if site of service is facility setting 14 ; TIME = time in minutes, only passed on anesthesia CPT codes 15 ; Returns string 16 ; dollar amount^sched year OR null value if not on RBRVS schedule 17 ; Output 18 ; FBERR( array of error messages OR undefined if none 19 ; 20 N FBAMT,FBCF,FBCPT0,FBCPTY0,FBCY,FBERR,FBGPCIY0 21 ; 22 ; initialization 23 S FBAMT="" 24 K FBERR 25 ; 26 ; check for required input parameters 27 I $G(CPT)="" D ERR^FBAAFS("CPT missing") 28 I $G(DOS)'?7N D ERR^FBAAFS("Date of Service missing") 29 I $D(FBERR) Q FBAMT 30 ; 31 ;if date of service prior to VA implementation, don't use RBRVS 32 I DOS<2990901 Q FBAMT 33 ; 34 ;if modifier SG present, don't use RBRVS, patch FB*3.5*84 35 I MODL["SG" Q FBAMT 36 ; 37 ; determine schedule calendar year based on date of service 38 S FBCY=$E(DOS,1,3)+1700 39 ; 40 ;If date of service in 2003 but prior to Mar 1, 2003 treat as 2002 41 I $E(DOS,1,3)=303,DOS<3030301 S FBCY=FBCY-1 42 ; 43 ; if year after most recent RBRVS schedule then use prior year schedule 44 I FBCY>$$LASTCY() S FBCY=FBCY-1 45 ; 46 ; get procedure data from schedule for year 47 D PROC(CPT,MODL,FBCY) 48 ; 49 ; if procedure: 50 ; - covered 51 ; - payable 52 ; - not for anesthesia 53 ; then calculate amount 54 I FBCPTY0]"",'$$ANES^FBAAFS(CPT) D 55 . ; 56 . ;validate parameters 57 . I $G(ZIP)="" D ERR^FBAAFS("Missing ZIP Code") 58 . I $G(FAC)="" D ERR^FBAAFS("Missing Facility Flag") 59 . I $D(FBERR) Q 60 . ; 61 . ; get GPCIs for calendar year 62 . D ZIP(FBCY,ZIP) 63 . I FBGPCIY0="" D ERR^FBAAFS("Could not determine GPCIs") Q 64 . ; 65 . ; get conversion factor 66 . S FBCF=$$CF(FBCY,$P(FBCPT0,U,2)) 67 . I FBCF="" D ERR^FBAAFS("Could not determine the conversion factor") Q 68 . ; 69 . ; calculate full schedule amount 70 . D CALC(FBCY,FAC,FBCPTY0,FBGPCIY0,FBCF) 71 . ; 72 . ; apply multiplier based on modifier 73 . I MODL]"" S FBAMT=FBAMT*$$MULT(FBCY,MODL,FBCPT0,FBCPTY0) 74 ; 75 ; return result 76 Q $S(FBAMT>0:$J(FBAMT,0,2)_U_FBCY,1:"") 77 ; 78 PROC(CPT,MODL,FBCY,FBNONPBL) ; get procedure data for RBRVS schedule 79 ; Input 80 ; CPT = CPT/HCPCS code (external value) 81 ; MODL = list of CPT/HCPCS modifiers (external value) 82 ; delimited by commas 83 ; FBCY = calendar year (4 digit) 84 ; FBNONPBL ( optional): 85 ; if $G(FBNONPBL)=0 then will make search among payable records only in #162.97 86 ; ignoring those non-payable ones with field #.08 NONPAYABLE = 1 87 ; if $G(FBNONPBL)=1 then will make search among all items in #162.97 88 ; 89 ; Output 90 ; FBCPT0 = zero node from file 162.97 OR "" if not covered 91 ; FBCPTY0 = zero node from subfile 162.971 or "" if not covered 92 N CPTM,MOD,FBI 93 S (FBCPT0,FBCPTY0)="" 94 Q:$G(FBCY)']""!($G(CPT)']"") 95 ; 96 ; if modifier exists try to find entry with modifier 97 I MODL]"" D 98 . F FBI=1:1 S MOD=$P(MODL,",",FBI) Q:MOD="" D Q:FBCPTY0]"" 99 . . S CPTM=CPT_"-"_MOD 100 . . D PROC1(CPTM,FBCY,$G(FBNONPBL)) 101 ; 102 ; if not found with modifier, try just CPT code 103 I FBCPTY0="" D PROC1(CPT,FBCY,$G(FBNONPBL)) 104 ; 105 Q 106 ; 107 PROC1(CPTM,FBCY,FBNONPBL) ; get procedure data for CPT-Modifier 108 ; input 109 ; CPTM - CPT Code - Modifier (e.g. 57335-TC or 57335) 110 ; FBCY - 4 digit calendar year 111 ; FBNONPBL ( optional): 112 ; if $G(FBNONPBL)=0 then will make search among payable records only in #162.97 113 ; ignoring those non-payable ones with field #.08 NONPAYABLE = 1 114 ; if $G(FBNONPBL)=1 then will make search among all items in #162.97 115 ; output 116 ; FBCPT0 = zero node from file 162.97 OR "" if not covered 117 ; FBCPTY0 = zero node from subfile 162.971 or "" if not covered 118 N FBDA,FBDA1 119 S (FBCPT0,FBCPTY0)="" 120 S FBDA=$O(^FB(162.97,"B",CPTM,0)) 121 S FBDA1=$S(FBDA:$O(^FB(162.97,FBDA,"CY","B",FBCY,0)),1:"") 122 I $G(FBDA),$G(FBDA1) D 123 . N FBI,FBSUM,FBY 124 . S FBY=$G(^FB(162.97,FBDA,"CY",FBDA1,0)) 125 . ;if non-payable records should not be considered 126 . ;then quit if this is NONPAYBLE 127 . I +$G(FBNONPBL)=0 Q:$P(FBY,U,8)=1 128 . ; check if procedure covered by schedule 129 . I +$G(FBNONPBL)=0,$$ANES^FBAAFS($P(CPTM,"-")),$P(FBY,U,6)']"" Q ; missing anes base 130 . I +$G(FBNONPBL)=0,'$$ANES^FBAAFS($P(CPTM,"-")) D I FBSUM'>0 Q ; sum of RVUs = 0 131 . . S FBSUM=0 F FBI=3,4,5,6 S FBSUM=FBSUM+$P(FBY,U,FBI) 132 . ; passed checks 133 . S FBCPTY0=FBY 134 . S FBCPT0=$G(^FB(162.97,FBDA,0)) 135 Q 136 ; 137 ZIP(FBCY,ZIP) ; get GPCIs 138 ; Input 139 ; FBCY = calendar year (4 digit) 140 ; ZIP = zip code (5 digit external value) 141 ; Output 142 ; FBGPCIY0 = zero node from file 162.96 or "" if not found 143 S FBGPCIY0="" 144 Q:$G(FBCY)']""!($G(ZIP)']"") 145 N FBDA,FBDA1 146 S FBDA=$O(^FB(162.96,"B",ZIP,0)) 147 S FBDA1=$S(FBDA:$O(^FB(162.96,FBDA,"CY","B",FBCY,0)),1:"") 148 I FBDA,FBDA1 S FBGPCIY0=$G(^FB(162.96,FBDA,"CY",FBDA1,0)) 149 Q 150 ; 151 CF(FBCY,FBDA) ; get conversion factor 152 ; Input 153 ; FBCY = calendar year 154 ; FBDA = optional conversion category (internal) 155 ; Returns 156 ; conversion factor from file 162.99 157 N FBCF,FBDA1 158 I '$G(FBDA) S FBDA=4 ; use Medicine category if not specified 159 S FBDA1=$O(^FB(162.99,FBDA,"CY","B",FBCY,0)) 160 S FBCF=$S(FBDA1:$P($G(^FB(162.99,FBDA,"CY",FBDA1,0)),U,2),1:"") 161 Q +FBCF 162 ; 163 CALC(FBCY,FAC,FBCPTY0,FBGPCIY0,FBCF) ; 164 ; Input 165 ; FBCY = calendar year (4 digit) 166 ; FAC = facility flag (0 or 1) 167 ; FBCPTY0 = zero node from file 162.71 168 ; FBGPCI0 = zero node from file 162.61 169 ; FBCF = conversion factor (number) 170 ; Returns $ amount 171 ; 172 N GPCI,RVU,FBI,TMP,TMPRVU 173 S FBAMT=0 174 ;Old formula for RBRVS pre-2007 payment amounts 175 I DOS<3070101 D 176 .S RVU(1)=$P(FBCPTY0,U,3) 177 I (DOS=3070101!(DOS>3070101)&(DOS<3080101)) D 178 .;New formula for RBRVS 2007 payment amounts 179 .;Multiply Work RVU by the Budget Neutrality Adjustor (0.8994) 180 .S TMP=$P(FBCPTY0,U,3),TMPRVU=$J((TMP*(.8994)),".",2) 181 .S RVU(1)=TMPRVU 182 I DOS=3080101!(DOS>3080101) D 183 .;New formula for the RBRVS 2008 payment amounts 184 .;Multiply Work RVU by the Budget Neutrality Adjustor (0.8994) 185 .S TMP=$P(FBCPTY0,U,3),TMPRVU=$J((TMP*(.8806)),".",2) 186 .S RVU(1)=TMPRVU 187 S RVU(2)=$P(FBCPTY0,U,4+FAC) 188 S RVU(3)=$P(FBCPTY0,U,6) 189 F FBI=2,3,4 S GPCI(FBI-1)=$P(FBGPCIY0,U,FBI) 190 S FBAMT=((RVU(1)*GPCI(1))+(RVU(2)*GPCI(2))+(RVU(3)*GPCI(3)))*FBCF 191 ; some procedures can't be performed in a facility setting by 192 ; definition. the facility PE RVU for such a procedure is a null 193 ; value. 194 ; when facility setting - check for a null PE value and don't return amt 195 I RVU(2)="",FAC S FBAMT=0 Q 196 Q 197 ; 198 MULT(FBCY,MODL,FBCPT0,FBCPTY0) ;returns multiplier based on table type 199 ; Input 200 ; FBCY = calendar year (4 digit) 201 ; MODL = list of CPT/HCPCS modifiers (external values) 202 ; delimited by commas 203 ; FBCPT0 = zero node of file 162.7 for procedure 204 ; FBCPTY0 = zero node of subfile 162.71 for year 205 ; Returns 206 ; multiplier value OR 1 if none 207 N FBDA,FBDA1,FBI,FBML,FBPD,FBRET,FBTBL,MOD 208 S FBRET=1 209 S FBML=$P(FBCPTY0,U,2) ; mod level table for procedure 210 I MODL]"",FBML]"",FBCY]"" D 211 . S FBTBL=FBCY_"-"_FBML ; mod level table for year 212 . S FBDA=$O(^FB(162.98,"B",FBTBL,0)) 213 . Q:'FBDA ; table not found 214 . ; loop thru the modifiers 215 . F FBI=1:1 S MOD=$P(MODL,",",FBI) Q:MOD="" D 216 . . I $P($P(FBCPT0,U),"-",2)=MOD Q ; modifier already built in schedule 217 . . ; look up modifier in mod level table 218 . . S FBDA1=$O(^FB(162.98,FBDA,"M","B",MOD,0)) 219 . . Q:'FBDA1 ; modifier not found in table 220 . . S FBPD=$P($G(^FB(162.98,FBDA,"M",FBDA1,0)),U,2) ; percentage 221 . . I FBPD>0 S FBRET=FBRET*(FBPD/100) ; multiplier 222 Q FBRET 223 ; 224 LASTCY() ; Determine last calendar year of RBRVS FEE schedule data 225 ; based on last year for Medicine conversion factor 226 N YEAR 227 S YEAR=$O(^FB(162.99,4,"CY","B"," "),-1) 228 Q YEAR 229 ;FBAAFSR 1 FBAAFSR ;WCIOFO/TCK,SS,DMK,SAB-RBRVS FEE SCHEDULE ; 8/26/1999 2 ;;3.5;FEE BASIS;**4,53,71,84,92,93,99,102**;JAN 30, 1995;Build 24 3 ; 4 Q 5 ; 6 RBRVS(CPT,MODL,DOS,ZIP,FAC,TIME) ; calculate RBRVS Fee Schedule amount 7 ; Input 8 ; CPT = CPT/HCPCS code (external value) 9 ; MODL = list of CPT/HCPCS modifiers (external values) 10 ; delimited by commas (e.g. "26,51") 11 ; DOS = date of service (fileman format e.g. 2980101) 12 ; ZIP = ZIP code of service (external 5 digit value) 13 ; FAC = facility flag =1 if site of service is facility setting 14 ; TIME = time in minutes, only passed on anesthesia CPT codes 15 ; Returns string 16 ; dollar amount^sched year OR null value if not on RBRVS schedule 17 ; Output 18 ; FBERR( array of error messages OR undefined if none 19 ; 20 N FBAMT,FBCF,FBCPT0,FBCPTY0,FBCY,FBERR,FBGPCIY0 21 ; 22 ; initialization 23 S FBAMT="" 24 K FBERR 25 ; 26 ; check for required input parameters 27 I $G(CPT)="" D ERR^FBAAFS("CPT missing") 28 I $G(DOS)'?7N D ERR^FBAAFS("Date of Service missing") 29 I $D(FBERR) Q FBAMT 30 ; 31 ;if date of service prior to VA implementation, don't use RBRVS 32 I DOS<2990901 Q FBAMT 33 ; 34 ;if modifier SG present, don't use RBRVS, patch FB*3.5*84 35 I MODL["SG" Q FBAMT 36 ; 37 ; determine schedule calendar year based on date of service 38 S FBCY=$E(DOS,1,3)+1700 39 ; 40 ;If date of service in 2003 but prior to Mar 1, 2003 treat as 2002 41 I $E(DOS,1,3)=303,DOS<3030301 S FBCY=FBCY-1 42 ; 43 ; if year after most recent RBRVS schedule then use prior year schedule 44 I FBCY>$$LASTCY() S FBCY=FBCY-1 45 ; 46 ; get procedure data from schedule for year 47 D PROC(CPT,MODL,FBCY) 48 ; 49 ; if procedure: 50 ; - covered 51 ; - payable 52 ; - not for anesthesia 53 ; then calculate amount 54 I FBCPTY0]"",'$$ANES^FBAAFS(CPT) D 55 . ; 56 . ;validate parameters 57 . I $G(ZIP)="" D ERR^FBAAFS("Missing ZIP Code") 58 . I $G(FAC)="" D ERR^FBAAFS("Missing Facility Flag") 59 . I $D(FBERR) Q 60 . ; 61 . ; get GPCIs for calendar year 62 . D ZIP(FBCY,ZIP) 63 . I FBGPCIY0="" D ERR^FBAAFS("Could not determine GPCIs") Q 64 . ; 65 . ; get conversion factor 66 . S FBCF=$$CF(FBCY,$P(FBCPT0,U,2)) 67 . I FBCF="" D ERR^FBAAFS("Could not determine the conversion factor") Q 68 . ; 69 . ; calculate full schedule amount 70 . D CALC(FBCY,FAC,FBCPTY0,FBGPCIY0,FBCF) 71 . ; 72 . ; apply multiplier based on modifier 73 . I MODL]"" S FBAMT=FBAMT*$$MULT(FBCY,MODL,FBCPT0,FBCPTY0) 74 ; 75 ; return result 76 Q $S(FBAMT>0:$J(FBAMT,0,2)_U_FBCY,1:"") 77 ; 78 PROC(CPT,MODL,FBCY,FBNONPBL) ; get procedure data for RBRVS schedule 79 ; Input 80 ; CPT = CPT/HCPCS code (external value) 81 ; MODL = list of CPT/HCPCS modifiers (external value) 82 ; delimited by commas 83 ; FBCY = calendar year (4 digit) 84 ; FBNONPBL ( optional): 85 ; if $G(FBNONPBL)=0 then will make search among payable records only in #162.97 86 ; ignoring those non-payable ones with field #.08 NONPAYABLE = 1 87 ; if $G(FBNONPBL)=1 then will make search among all items in #162.97 88 ; 89 ; Output 90 ; FBCPT0 = zero node from file 162.97 OR "" if not covered 91 ; FBCPTY0 = zero node from subfile 162.971 or "" if not covered 92 N CPTM,MOD,FBI 93 S (FBCPT0,FBCPTY0)="" 94 Q:$G(FBCY)']""!($G(CPT)']"") 95 ; 96 ; if modifier exists try to find entry with modifier 97 I MODL]"" D 98 . F FBI=1:1 S MOD=$P(MODL,",",FBI) Q:MOD="" D Q:FBCPTY0]"" 99 . . S CPTM=CPT_"-"_MOD 100 . . D PROC1(CPTM,FBCY,$G(FBNONPBL)) 101 ; 102 ; if not found with modifier, try just CPT code 103 I FBCPTY0="" D PROC1(CPT,FBCY,$G(FBNONPBL)) 104 ; 105 Q 106 ; 107 PROC1(CPTM,FBCY,FBNONPBL) ; get procedure data for CPT-Modifier 108 ; input 109 ; CPTM - CPT Code - Modifier (e.g. 57335-TC or 57335) 110 ; FBCY - 4 digit calendar year 111 ; FBNONPBL ( optional): 112 ; if $G(FBNONPBL)=0 then will make search among payable records only in #162.97 113 ; ignoring those non-payable ones with field #.08 NONPAYABLE = 1 114 ; if $G(FBNONPBL)=1 then will make search among all items in #162.97 115 ; output 116 ; FBCPT0 = zero node from file 162.97 OR "" if not covered 117 ; FBCPTY0 = zero node from subfile 162.971 or "" if not covered 118 N FBDA,FBDA1 119 S (FBCPT0,FBCPTY0)="" 120 S FBDA=$O(^FB(162.97,"B",CPTM,0)) 121 S FBDA1=$S(FBDA:$O(^FB(162.97,FBDA,"CY","B",FBCY,0)),1:"") 122 I $G(FBDA),$G(FBDA1) D 123 . N FBI,FBSUM,FBY 124 . S FBY=$G(^FB(162.97,FBDA,"CY",FBDA1,0)) 125 . ;if non-payable records should not be considered 126 . ;then quit if this is NONPAYBLE 127 . I +$G(FBNONPBL)=0 Q:$P(FBY,U,8)=1 128 . ; check if procedure covered by schedule 129 . I +$G(FBNONPBL)=0,$$ANES^FBAAFS($P(CPTM,"-")),$P(FBY,U,6)']"" Q ; missing anes base 130 . I +$G(FBNONPBL)=0,'$$ANES^FBAAFS($P(CPTM,"-")) D I FBSUM'>0 Q ; sum of RVUs = 0 131 . . S FBSUM=0 F FBI=3,4,5,6 S FBSUM=FBSUM+$P(FBY,U,FBI) 132 . ; passed checks 133 . S FBCPTY0=FBY 134 . S FBCPT0=$G(^FB(162.97,FBDA,0)) 135 Q 136 ; 137 ZIP(FBCY,ZIP) ; get GPCIs 138 ; Input 139 ; FBCY = calendar year (4 digit) 140 ; ZIP = zip code (5 digit external value) 141 ; Output 142 ; FBGPCIY0 = zero node from file 162.96 or "" if not found 143 S FBGPCIY0="" 144 Q:$G(FBCY)']""!($G(ZIP)']"") 145 N FBDA,FBDA1 146 S FBDA=$O(^FB(162.96,"B",ZIP,0)) 147 S FBDA1=$S(FBDA:$O(^FB(162.96,FBDA,"CY","B",FBCY,0)),1:"") 148 I FBDA,FBDA1 S FBGPCIY0=$G(^FB(162.96,FBDA,"CY",FBDA1,0)) 149 Q 150 ; 151 CF(FBCY,FBDA) ; get conversion factor 152 ; Input 153 ; FBCY = calendar year 154 ; FBDA = optional conversion category (internal) 155 ; Returns 156 ; conversion factor from file 162.99 157 N FBCF,FBDA1 158 I '$G(FBDA) S FBDA=4 ; use Medicine category if not specified 159 S FBDA1=$O(^FB(162.99,FBDA,"CY","B",FBCY,0)) 160 S FBCF=$S(FBDA1:$P($G(^FB(162.99,FBDA,"CY",FBDA1,0)),U,2),1:"") 161 Q +FBCF 162 ; 163 CALC(FBCY,FAC,FBCPTY0,FBGPCIY0,FBCF) ; 164 ; Input 165 ; FBCY = calendar year (4 digit) 166 ; FAC = facility flag (0 or 1) 167 ; FBCPTY0 = zero node from file 162.71 168 ; FBGPCI0 = zero node from file 162.61 169 ; FBCF = conversion factor (number) 170 ; Returns $ amount 171 ; 172 N GPCI,RVU,FBI,TMP,TMPRVU 173 S FBAMT=0 174 ;Multiply Work RVU by the Budget Neutrality Adjustor (0.8994) 175 I DOS<3070101 D 176 .;Old formula for RBRVS pre-2007 payment amounts 177 .S RVU(1)=$P(FBCPTY0,U,3) 178 I DOS>3061231 D 179 .;New formula for RBRVS 2007 payment amounts 180 .;Multiply Work RVU by the Budget Neutrality Adjustor (0.8994) 181 .S TMP=$P(FBCPTY0,U,3),TMPRVU=$J((TMP*(.8994)),".",2) 182 .S RVU(1)=TMPRVU 183 S RVU(2)=$P(FBCPTY0,U,4+FAC) 184 S RVU(3)=$P(FBCPTY0,U,6) 185 F FBI=2,3,4 S GPCI(FBI-1)=$P(FBGPCIY0,U,FBI) 186 S FBAMT=((RVU(1)*GPCI(1))+(RVU(2)*GPCI(2))+(RVU(3)*GPCI(3)))*FBCF 187 ; some procedures can't be performed in a facility setting by 188 ; definition. the facility PE RVU for such a procedure is a null 189 ; value. 190 ; when facility setting - check for a null PE value and don't return amt 191 I RVU(2)="",FAC S FBAMT=0 Q 192 Q 193 ; 194 MULT(FBCY,MODL,FBCPT0,FBCPTY0) ;returns multiplier based on table type 195 ; Input 196 ; FBCY = calendar year (4 digit) 197 ; MODL = list of CPT/HCPCS modifiers (external values) 198 ; delimited by commas 199 ; FBCPT0 = zero node of file 162.7 for procedure 200 ; FBCPTY0 = zero node of subfile 162.71 for year 201 ; Returns 202 ; multiplier value OR 1 if none 203 N FBDA,FBDA1,FBI,FBML,FBPD,FBRET,FBTBL,MOD 204 S FBRET=1 205 S FBML=$P(FBCPTY0,U,2) ; mod level table for procedure 206 I MODL]"",FBML]"",FBCY]"" D 207 . S FBTBL=FBCY_"-"_FBML ; mod level table for year 208 . S FBDA=$O(^FB(162.98,"B",FBTBL,0)) 209 . Q:'FBDA ; table not found 210 . ; loop thru the modifiers 211 . F FBI=1:1 S MOD=$P(MODL,",",FBI) Q:MOD="" D 212 . . I $P($P(FBCPT0,U),"-",2)=MOD Q ; modifier already built in schedule 213 . . ; look up modifier in mod level table 214 . . S FBDA1=$O(^FB(162.98,FBDA,"M","B",MOD,0)) 215 . . Q:'FBDA1 ; modifier not found in table 216 . . S FBPD=$P($G(^FB(162.98,FBDA,"M",FBDA1,0)),U,2) ; percentage 217 . . I FBPD>0 S FBRET=FBRET*(FBPD/100) ; multiplier 218 Q FBRET 219 ; 220 LASTCY() ; Determine last calendar year of RBRVS FEE schedule data 221 ; based on last year for Medicine conversion factor 222 N YEAR 223 S YEAR=$O(^FB(162.99,4,"CY","B"," "),-1) 224 Q YEAR 225 ;FBAAFSR -
WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBCH78.m
r613 r623 1 FBCH78 ;AISC/DMK-SETS UP 7078/AUTHORIZATION FOR CONTRACT HOSPITAL ;08/07/02 2 ;;3.5;FEE BASIS;**43,103**;JAN 30, 1995;Build 19 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 S DIC("S")="I $P(^(0),U,15)=3&($P(^(0),U,12)=""Y"")" D ASKV^FBCHREQ G END:$E(X)="^"!($E(X)="")!('$D(FBDA)) 5 I $P(^FBAA(162.2,FBDA,0),"^",17)]"" W !!,*7,"There already is a 7078 set up for this request.",!,"The number is ",$P(^FB7078($P(^FBAA(162.2,FBDA,0),"^",17),0),"^")," .",! G END 6 EN S FBVEN=$P(^FBAA(162.2,FBDA,0),"^",2)_";FBAAV(",FBVET=$P(^(0),"^",4),FBFRDT=$P(^(0),"^",5),FBFRDT=FBFRDT\1,FBDOA=$S($P(^(0),"^",19):$P(^(0),"^",19)\1,1:""),FBDXS=$P(^(0),"^",6) 7 ;FB*3.5*103 ;added FBRP 8 S FBRP=$P($G(^FBAA(162.2,FBDA,2)),"^") K DA 9 W !! S %DT="APEX",%DT("A")="AUTHORIZATION TO DATE: " D ^%DT K %DT G END:X="^" S FBTODT=$S(X="":"",1:Y) 10 I FBTODT]"",FBFRDT>FBTODT W !!,*7,?5,"Authorization To Date must be after Authorization From Date!",! G EN 11 W !! S %DT="APEX",%DT("A")="DATE OF DISCHARGE: ",%DT("B")=$$DATX^FBAAUTL(FBTODT) D ^%DT K %DT G END:X="^" S FBDOD=$S(X="":"",1:Y) 12 I FBDOD]"",FBTODT>FBDOD W !!,*7,?5,"Date of Discharge must not be earlier than the Authorization To Date!",! G EN 13 S DIR(0)="162.4,5",DIR("A")="ADMITTING AUTHORITY" D ^DIR K DIR 14 G END:$D(DIRUT) S FBADMIT=+Y 15 S DIR(0)="162.4,6" D ^DIR K DIR 16 G END:$D(DIRUT) S FBEST=+Y 17 FBPDIS I FBTODT="" S DIR(0)="162.4,12" D ^DIR K DIR G END:$D(DUOUT),END:$D(DTOUT),NULL^FBCH780:X="" S FBPDIS=+Y 18 ; 19 ASKPT I FBTODT]"" S DIR(0)="SAO^00:SURGICAL;10:MEDICAL;86:PSYCHIATRY",DIR("A")="BEDSECTION/TREATING SPECIALTY: ",DIR("?")="^D HELP^FBCH780" D ^DIR K DIR D NOUP^FBCHCD:$D(DIRUT) G ASKPT:$D(DIRUT) S FBPT=Y 20 7078 S PRCS("A")="Select Obligation Number: ",PRCS("TYPE")="FB" D EN1^PRCS58 G:Y=-1 NOGOOD S (X,FBCHOB)=$P(Y,"^",2) K PRCS("A") S PRCS("TYPE")="FB" D EN1^PRCSUT31 G:Y="" NOGOOD S FB7078=$P(FBCHOB,"-",2)_"."_Y S FBSEQ=Y 21 S DIC="^FB7078(",DIC(0)="LQ",DLAYGO=162.4,X=""""_FB7078_"""" D ^DIC G:Y<0 PROB S (DA,FBAA78)=+Y 22 S DIE="^FBAA(162.2,",DA=FBDA,DR="16////^S X=FBAA78" D ^DIE K DIE,DIC,DA,DR 23 SET78 S DIE="^FB7078(",DA=FBAA78,DR="[FBCH ENTER 7078]" D ^DIE K DIC,DIE,DR,DA 24 D ^FBCH780 I $G(FBOUT) W !!,*7,"...deleting 7078." D DEL G END 25 I +Y=0 W !!,*7,Y,!,"...deleting 7078. Use 'Set-up a 7078' after adjusting 1358.",! D DEL G END 26 K DIE,DIC,DA 27 I $G(FBVET) S:'$G(DFN) DFN=FBVET D PTF^FBCH780 28 G SHOW:FBTODT="" 29 AUTH D HOME^%ZIS 30 D:'$D(FBSITE(1)) SITEP^FBAAUTL Q:FBPOP S FBPSA=$S($P(FBSITE(1),"^",3)="":"",$D(^DIC(4,$P(FBSITE(1),"^",3),0)):$P(^(0),"^"),1:"") 31 S FBVEN=$P(FBVEN,";") 32 I '$D(^FBAAA(FBVET,0)) L +^FBAAA(FBVET) K DD,DO S (X,DINUM)=FBVET,DIC="^FBAAA(",DIC(0)="LM",DLAYGO=161 D FILE^DICN L -^FBAAA(FBVET) G:Y<0 END 33 S:'$D(^FBAAA(FBVET,1,0)) ^(0)="^161.01D^^" 34 K DE,DQ,DR,DIE,DLAYGO 35 FBDCHG S DIR(0)="161.01,.06" D ^DIR K DIR G END:$D(DTOUT),END:$D(DUOUT) D NULL1^FBCH780:X="" G FBDCHG:X="" S FBDCHG=+Y 36 FBPUR S FBTYPE=6,DIR(0)="161.01,.07" D ^DIR K DIR S FBPUR=+Y 37 G END:$D(DTOUT),END:$D(DUOUT) 38 FBPSA S DIR(0)="161.01,101" D ^DIR K DIR G END:$D(DTOUT),END:$D(DUOUT) D NULL1^FBCH780:X="" G FBPSA:X="" S FBPSA=+Y 39 ;file entry in authorization multiple of file 161 40 S DIC="^FBAAA("_FBVET_",1,",DIC(0)="LM",DLAYGO=161,DA(1)=FBVET,X=FBFRDT K DD,DO D FILE^DICN G:Y<0 END S DA=+Y,DIE("NO^")="" ;DA(1)=FBVET 41 S FB78=FBAA78_";FB7078(" 42 ;FB*3.5*103 ;added FBRP 43 S DIE=DIC,DR=".02////^S X=FBTODT;.03////^S X=6;100////^S X=DUZ;1////^S X=""YES"";.055////^S X=FB78;.06////^S X=FBDCHG;S FBTYPE=6;.04////^S X=FBVEN;.065////^S X=FBPT;101////^S X=FBPSA" 44 S:$G(FBRP)]"" DR=DR_";104////^S X=FBRP" 45 S DR=DR_";.095////^S X=1" 46 S DR(1,161.01,1)="I $D(^FB7078(FBAA78,1,0)) S ^FBAAA(DA(1),1,DA,2,0)=^(0) F FBI=1:1 Q:'$D(^FB7078(FBAA78,1,FBI,0)) I $D(^(0)) S ^FBAAA(DA(1),1,DA,2,FBI,0)=^(0);.07////^S X=FBPUR;.08///^S X=FBDXS;.096;.097//^S X=""N""" 47 D ^DIE K DIE,DR 48 S (DIC,DIE)="^FB7078(",DA=FBAA78,DR="9///^S X=""C"";12///^S X=""@""" D ^DIE K DR,DIE,DA,X 49 SHOW W !! S DA=FBAA78,DR="0;1",DIC="^FB7078(" D EN^DIQ 50 ; 51 ;FB*3.5*103 ;added FBRP 52 END K D,DA,DIC,DIE,DIR,DLAYGO,DR,FBDA,FB7078,FBAA78,FBPT,FBTYPE,FBVEN,FBZ,FBVET,FBFRDT,FBTODT,J,S,POP,X,Y,DFN,FBCHOB,FBCOMM,FBDFN,FBEST,FBI,FBLENT,FBMENT,FBNAME,FBSEQ,FBSSN,FBSW,I,K,PRC,VAL,FB,FBFLG,ZZ,FBPSA,FBSITE,FB78,FBOUT 53 K FBDCHG,FBPUR,FBPDIS,FBADMIT,FBDXS,A,D0,D1,X1,DIRUT,DTOUT,DUOUT,FBDOA,FBDOD,FBPOP,FBZZ,ZZZ,PRCSCPAN,FBRP 54 Q 55 PROB W !!,"The reference number did not get set up with the",!,"IFCAP software. Contact your package coordinator." G END 56 NOGOOD S DIR(0)="Y",DIR("A")="Obligation number selected is invalid or you are not a control point user in the IFCAP package! Try again",DIR("B")="YES" D ^DIR K DIR G END:$D(DIRUT)!'Y,7078 57 ; 58 OUTP ;ENTRY TO DISPLAY A 7078 59 ;FB*3.5*103 ; Display the 0 node fields with computed REFERRING PROVIDER NPI, then 1 node fields 60 S DIC="^FB7078(",DIC(0)="AEQM",D="D",DIC("A")="Select Patient: " D IX^DIC 61 G END:X=""!(X="^") 62 S (DA,FBDA)=+Y,DR="0",DIQ(0)="C" W !! D EN^DIQ K DIQ(0) 63 S DA=FBDA,DR="1" D EN^DIQ 64 I $$DISCH^FBCH780(FBDA)]"" W ?2,"DISCHARGE TYPE: ",$$DISCH^FBCH780(FBDA),! 65 G OUTP 66 ; 67 REFNPI(IEN200,IEN162P4,CHKAUTH) ;FB*3.5*103 68 ; a new function that returns the REFERRING PROVIDER NPI if it is Active and the provider has authorized use of the NPI 69 ; If is used in both a Fileman function and in other FB routines. 70 ; 71 ; Input 72 ; IEN200 - IEN to file 200 if known 73 ; IEN162P4 (optional) - IEN to File 162.4 (if ref prov is not known) 74 ; CHKAUTH (optional) - Flag on whether to Chek Authorization in file 200 75 ; 76 ; Output 77 ; A valid/active NPI if one can be determined. Otherwise, nada. 78 ; 79 ; If neither IEN is passed in, there is no NPI coming out 80 I $G(IEN200)<1,$G(IEN162P4)<1 Q "" 81 ; 82 ; If there is no referrring provider IEN passed in, try getting it from the IEN from 162.4 (VA FORM 10-7078) 83 ; return nothing if you can't 84 I $G(IEN200)<1 S IEN200=$$GET1^DIQ(162.4,IEN162P4_",",15,"I") Q:$G(IEN200)<1 "" 85 ; 86 ; Now that we have an IEN to 200 see if we need authorization and have to display/print NPI 87 ; If the return value is less than 1, then we don't have permission or it was not a valid IEN. 88 ; IA#5070 89 I $G(CHKAUTH) Q:+$$GETRLNPI^XUSNPI(IEN200)<1 "" 90 ; 91 ; Go get the NPI for this IEN 92 N NPI S NPI=$$NPI^XUSNPI("Individual_ID",IEN200) 93 ; 94 ; Make sure it is a valid/Active NPI 95 I +NPI<1!($P(NPI,U,3)="Inactive") Q "" 96 Q +NPI 97 ; 98 DEL S DA=FBAA78,DIK="^FB7078(" D ^DIK K DIK S DA=$O(^FBAA(162.2,"AM",+FBAA78,0)) I DA S DIE="^FBAA(162.2,",DR="16///@" D ^DIE 1 FBCH78 ;AISC/DMK-SETS UP 7078/AUTHORIZATION FOR CONTRACT HOSPITAL ;08/07/02 2 ;;3.5;FEE BASIS;**43**;JAN 30, 1995 3 ;;Per VHA Directive 10-93-142, this routine should not be modified. 4 S DIC("S")="I $P(^(0),U,15)=3&($P(^(0),U,12)=""Y"")" D ASKV^FBCHREQ G END:$E(X)="^"!($E(X)="")!('$D(FBDA)) 5 I $P(^FBAA(162.2,FBDA,0),"^",17)]"" W !!,*7,"There already is a 7078 set up for this request.",!,"The number is ",$P(^FB7078($P(^FBAA(162.2,FBDA,0),"^",17),0),"^")," .",! G END 6 EN S FBVEN=$P(^FBAA(162.2,FBDA,0),"^",2)_";FBAAV(",FBVET=$P(^(0),"^",4),FBFRDT=$P(^(0),"^",5),FBFRDT=FBFRDT\1,FBDOA=$S($P(^(0),"^",19):$P(^(0),"^",19)\1,1:""),FBDXS=$P(^(0),"^",6) K DA 7 W !! S %DT="APEX",%DT("A")="AUTHORIZATION TO DATE: " D ^%DT K %DT G END:X="^" S FBTODT=$S(X="":"",1:Y) 8 I FBTODT]"",FBFRDT>FBTODT W !!,*7,?5,"Authorization To Date must be after Authorization From Date!",! G EN 9 W !! S %DT="APEX",%DT("A")="DATE OF DISCHARGE: ",%DT("B")=$$DATX^FBAAUTL(FBTODT) D ^%DT K %DT G END:X="^" S FBDOD=$S(X="":"",1:Y) 10 I FBDOD]"",FBTODT>FBDOD W !!,*7,?5,"Date of Discharge must not be earlier than the Authorization To Date!",! G EN 11 S DIR(0)="162.4,5",DIR("A")="ADMITTING AUTHORITY" D ^DIR K DIR 12 G END:$D(DIRUT) S FBADMIT=+Y 13 S DIR(0)="162.4,6" D ^DIR K DIR 14 G END:$D(DIRUT) S FBEST=+Y 15 FBPDIS I FBTODT="" S DIR(0)="162.4,12" D ^DIR K DIR G END:$D(DUOUT),END:$D(DTOUT),NULL^FBCH780:X="" S FBPDIS=+Y 16 ; 17 ASKPT I FBTODT]"" S DIR(0)="SAO^00:SURGICAL;10:MEDICAL;86:PSYCHIATRY",DIR("A")="BEDSECTION/TREATING SPECIALTY: ",DIR("?")="^D HELP^FBCH780" D ^DIR K DIR D NOUP^FBCHCD:$D(DIRUT) G ASKPT:$D(DIRUT) S FBPT=Y 18 7078 S PRCS("A")="Select Obligation Number: ",PRCS("TYPE")="FB" D EN1^PRCS58 G:Y=-1 NOGOOD S (X,FBCHOB)=$P(Y,"^",2) K PRCS("A") S PRCS("TYPE")="FB" D EN1^PRCSUT31 G:Y="" NOGOOD S FB7078=$P(FBCHOB,"-",2)_"."_Y S FBSEQ=Y 19 S DIC="^FB7078(",DIC(0)="LQ",DLAYGO=162.4,X=""""_FB7078_"""" D ^DIC G:Y<0 PROB S (DA,FBAA78)=+Y 20 S DIE="^FBAA(162.2,",DA=FBDA,DR="16////^S X=FBAA78" D ^DIE K DIE,DIC,DA,DR 21 SET78 S DIE="^FB7078(",DA=FBAA78,DR="[FBCH ENTER 7078]" D ^DIE K DIC,DIE,DR,DA 22 D ^FBCH780 I $G(FBOUT) W !!,*7,"...deleting 7078." D DEL G END 23 I +Y=0 W !!,*7,Y,!,"...deleting 7078. Use 'Set-up a 7078' after adjusting 1358.",! D DEL G END 24 K DIE,DIC,DA 25 I $G(FBVET) S:'$G(DFN) DFN=FBVET D PTF^FBCH780 26 G SHOW:FBTODT="" 27 AUTH D HOME^%ZIS 28 D:'$D(FBSITE(1)) SITEP^FBAAUTL Q:FBPOP S FBPSA=$S($P(FBSITE(1),"^",3)="":"",$D(^DIC(4,$P(FBSITE(1),"^",3),0)):$P(^(0),"^"),1:"") 29 S FBVEN=$P(FBVEN,";") 30 I '$D(^FBAAA(FBVET,0)) L +^FBAAA(FBVET) K DD,DO S (X,DINUM)=FBVET,DIC="^FBAAA(",DIC(0)="LM",DLAYGO=161 D FILE^DICN L -^FBAAA(FBVET) G:Y<0 END 31 S:'$D(^FBAAA(FBVET,1,0)) ^(0)="^161.01D^^" 32 K DE,DQ,DR,DIE,DLAYGO 33 FBDCHG S DIR(0)="161.01,.06" D ^DIR K DIR G END:$D(DTOUT),END:$D(DUOUT) D NULL1^FBCH780:X="" G FBDCHG:X="" S FBDCHG=+Y 34 FBPUR S FBTYPE=6,DIR(0)="161.01,.07" D ^DIR K DIR S FBPUR=+Y 35 G END:$D(DTOUT),END:$D(DUOUT) 36 FBPSA S DIR(0)="161.01,101" D ^DIR K DIR G END:$D(DTOUT),END:$D(DUOUT) D NULL1^FBCH780:X="" G FBPSA:X="" S FBPSA=+Y 37 ;file entry in authorization multiple of file 161 38 S DIC="^FBAAA("_FBVET_",1,",DIC(0)="LM",DLAYGO=161,DA(1)=FBVET,X=FBFRDT K DD,DO D FILE^DICN G:Y<0 END S DA=+Y,DIE("NO^")="" ;DA(1)=FBVET 39 S FB78=FBAA78_";FB7078(" 40 S DIE=DIC,DR=".02////^S X=FBTODT;.03////^S X=6;100////^S X=DUZ;1////^S X=""YES"";.055////^S X=FB78;.06////^S X=FBDCHG;S FBTYPE=6;.04////^S X=FBVEN;.065////^S X=FBPT;101////^S X=FBPSA;.095////^S X=1" 41 S DR(1,161.01,1)="I $D(^FB7078(FBAA78,1,0)) S ^FBAAA(DA(1),1,DA,2,0)=^(0) F FBI=1:1 Q:'$D(^FB7078(FBAA78,1,FBI,0)) I $D(^(0)) S ^FBAAA(DA(1),1,DA,2,FBI,0)=^(0);.07////^S X=FBPUR;.08///^S X=FBDXS;.096;.097//^S X=""N""" 42 D ^DIE K DIE,DR 43 S (DIC,DIE)="^FB7078(",DA=FBAA78,DR="9///^S X=""C"";12///^S X=""@""" D ^DIE K DIE,DIE,DA,X 44 SHOW W !! S DA=FBAA78,DR="0;1",DIC="^FB7078(" D EN^DIQ 45 ; 46 END K D,DA,DIC,DIE,DIR,DLAYGO,DR,FBDA,FB7078,FBAA78,FBPT,FBTYPE,FBVEN,FBZ,FBVET,FBFRDT,FBTODT,J,S,POP,X,Y,DFN,FBCHOB,FBCOMM,FBDFN,FBEST,FBI,FBLENT,FBMENT,FBNAME,FBSEQ,FBSSN,FBSW,I,K,PRC,VAL,FB,FBFLG,ZZ,FBPSA,FBSITE,FB78,FBOUT 47 K FBDCHG,FBPUR,FBPDIS,FBADMIT,FBDXS,A,D0,D1,X1,DIRUT,DTOUT,DUOUT,FBDOA,FBDOD,FBPOP,FBZZ,ZZZ,PRCSCPAN 48 Q 49 PROB W !!,"The reference number did not get set up with the",!,"IFCAP software. Contact your package coordinator." G END 50 NOGOOD S DIR(0)="Y",DIR("A")="Obligation number selected is invalid or you are not a control point user in the IFCAP package! Try again",DIR("B")="YES" D ^DIR K DIR G END:$D(DIRUT)!'Y,7078 51 ; 52 OUTP ;ENTRY TO DISPLAY A 7078 53 S DIC="^FB7078(",DIC(0)="AEQM",D="D",DIC("A")="Select Patient: " D IX^DIC G END:X=""!(X="^") S (DA,FBDA)=+Y,DR="0;1" W !! D EN^DIQ 54 I $$DISCH^FBCH780(FBDA)]"" W ?2,"DISCHARGE TYPE: ",$$DISCH^FBCH780(FBDA),! 55 G OUTP 56 DEL S DA=FBAA78,DIK="^FB7078(" D ^DIK K DIK S DA=$O(^FBAA(162.2,"AM",+FBAA78,0)) I DA S DIE="^FBAA(162.2,",DR="16///@" D ^DIE -
WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBCH78A.m
r613 r623 1 FBCH78A ;AISC/DMK-PRINT 7078 CONTINUED FROM FBCHP78 ;06FEB89 2 ;;3.5;FEE BASIS;**103**;JAN 30, 1995;Build 19 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 HED W:'$G(FBPG) @IOF K:$G(FBPG) FBPG W UL,!,?5,"Department of Veterans Affairs",?58,"AUTHORIZATION AND INVOICE FOR MEDICAL AND HOSPITAL SERVICES",!,UL,! 5 Q 6 BOT W !,"SPECIAL PROVISIONS: Acceptance of this authorization to render service is governed by the following:",!! 7 W "1. ACCEPTANCE OF THIS AUTHORIZATION AND PROVIDING OF SUCH TREATMENT OR SERVICES SUBJECTS YOU, THE PROVIDER OF CARE, TO",!,?3,"THE PROVISIONS OF PUBLIC LAW 93-579, THE PRIVACY ACT OF 1974, TO THE EXTENT OF THE RECORDS " 8 W "PERTAINING TO THE VA",!,?3,"AUTHORIZED TREATMENT OR SERVICES OF THIS VETERAN.",! 9 W !,"2. Fees or rates listed represent maximum allowance for services specified. In no event should charges be made to the",!,?3,"VA in excess of usual and customary charges to the general public for similar services.",! 10 W !,"3. Payment by the VA is payment in full for authorized services rendered.",! 11 W !,"4. Unless otherwise approved by the VA, services are limited in type and extent to those shown on this authorization.",!,?3,"If services are not initiated for any reason, return a copy of the authorization to the issuing ",! 12 W ?3,"office with a brief explanation.",! 13 W !,"5. A copy of the Operative Report will be forwarded to the Authorizing station within one week following any major",!,?3,"surgery.",! 14 W !,"6. A copy of the hospital summary will be forwarded to the authorizing station within ten work days following the ",!,?3,"release of the patient from the hospital.",! 15 W !,"7. When submitting claims for payment you must include the NPI and Taxonomy Code of the rendering practitioner," 16 W !,?3,"and the NPI and Taxonomy Code of your organization. If, under the HIPAA NPI Final Rule" 17 W !,?3,"[http://www.cms.hhs.gov/NationalProvIdentStand], your organization is an ""atypical"" provider furnishing services such" 18 W !,?3,"as taxi, home and vehicle modifications, insect control, habilitation, and respite services and is therefore" 19 W !,?3,"ineligible for an NPI, it is important that you indicate ""Ineligible for NPI"" on your claim form.",! 20 W UL,!,?16,"All questions relating to this authorization should be referred to the issuing VA Office",!,UL,!,"VA Form 10-7078" Q 21 ; 22 FISCAL ;SETS THE FISCAL SYMBOL BLOCK FOR 7078 23 S PRC("SITE")=FB("SITE"),PRCS("X")=PRC("SITE")_"-"_$P($P(FB(0),"^"),"."),PRCS("TYPE")="FB" D EN1^PRCS58 24 S FB("SYM")=$P(Y,"^",4)_" "_$P(FB(0),"^")_" FCP "_$P(Y,U,3) K PRC("SITE"),PRCSI,Y Q 25 ; 26 CONT(X,Y) ;get contract for CNH authorization 27 ;X=IEN of vendor 28 ;Y=from date of authorization 29 I $S('$G(X):1,'$G(Y):1,1:0) Q "" 30 I '$O(^FBAA(161.21,"ACR",X,-Y+.9)) Q "" 31 N Z 32 S Z=$P(^FBAA(161.21,+$O(^(+$O(^FBAA(161.21,"ACR",X,-Y+.9)),0)),0),U,1,3) 33 Q $S($P(Z,U,3)>Y:$P(Z,U),1:"") 1 FBCH78A ;AISC/DMK-PRINT 7078 CONTINUED FROM FBCHP78 ;06FEB89 2 ;;3.5;FEE BASIS;;JAN 30, 1995 3 ;;Per VHA Directive 10-93-142, this routine should not be modified. 4 HED W:'$G(FBPG) @IOF K:$G(FBPG) FBPG W UL,!,?5,"Department of Veterans Affairs",?58,"AUTHORIZATION AND INVOICE FOR MEDICAL AND HOSPITAL SERVICES",!,UL,! 5 Q 6 BOT W !,"SPECIAL PROVISIONS: Acceptance of this authorization to render service is governed by the following:",!! 7 W "1. ACCEPTANCE OF THIS AUTHORIZATION AND PROVIDING OF SUCH TREATMENT OR SERVICES SUBJECTS YOU, THE PROVIDER OF CARE, TO",!,?3,"THE PROVISIONS OF PUBLIC LAW 93-579, THE PRIVACY ACT OF 1974, TO THE EXTENT OF THE RECORDS " 8 W "PERTAINING TO THE VA",!,?3,"AUTHORIZED TREATMENT OR SERVICES OF THIS VETERAN.",! 9 W !,"2. Fees or rates listed represent maximum allowance for services specified. In no event should charges be made to the",!,?3,"VA in excess of usual and customary charges to the general public for similar services.",! 10 W !,"3. Payment by the VA is payment in full for authorized services rendered.",! 11 W !,"4. Unless otherwise approved by the VA, services are limited in type and extent to those shown on this authorization.",!,?3,"If services are not initiated for any reason, return a copy of the authorization to the issuing ",! 12 W ?3,"office with a brief explanation.",! 13 W !,"5. A copy of the Operative Report will be forwarded to the Authorizing station within one week following any major",!,?3,"surgery.",! 14 W !,"6. A copy of the hospital summary will be forwarded to the authorizing station within ten work days following the ",!,?3,"release of the patient from the hospital.",! 15 W UL,!,?16,"All questions relating to this authorization should be referred to the issuing VA Office",!,UL,!,"VA Form 10-7078" Q 16 ; 17 FISCAL ;SETS THE FISCAL SYMBOL BLOCK FOR 7078 18 S PRC("SITE")=FB("SITE"),PRCS("X")=PRC("SITE")_"-"_$P($P(FB(0),"^"),"."),PRCS("TYPE")="FB" D EN1^PRCS58 19 S FB("SYM")=$P(Y,"^",4)_" "_$P(FB(0),"^")_" FCP "_$P(Y,U,3) K PRC("SITE"),PRCSI,Y Q 20 ; 21 CONT(X,Y) ;get contract for CNH authorization 22 ;X=IEN of vendor 23 ;Y=from date of authorization 24 I $S('$G(X):1,'$G(Y):1,1:0) Q "" 25 I '$O(^FBAA(161.21,"ACR",X,-Y+.9)) Q "" 26 N Z 27 S Z=$P(^FBAA(161.21,+$O(^(+$O(^FBAA(161.21,"ACR",X,-Y+.9)),0)),0),U,1,3) 28 Q $S($P(Z,U,3)>Y:$P(Z,U),1:"") -
WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBCHP78.m
r613 r623 1 FBCHP78 ;AISC/DMK-GENERATE 7078 ;7/NOV/2006 2 ;;3.5;FEE BASIS;**12,23,52,101,103**;JAN 30, 1995;Build 19 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 I '$D(^FBAA(161.4,1,0)) W !,"Site Parameters must be entered prior",!," to using this option." Q 5 GET78 S DIC="^FB7078(",DIC(0)="AEQMZ",DIC("A")="Select Veteran: ",D="D",DIC("S")="I $P(^(0),U,9)'=""DC""" D IX^DIC G END:X="^"!(X=""),GET78:Y<0 S FB7078=+Y,FB(0)=Y(0) K DIC,D 6 S DA=FB7078,DIC="^FB7078(",DR=0 D EN^DIQ 7 ASK S DIR(0)="Y",DIR("A")="Is this the correct 7078",DIR("B")="YES" D ^DIR K DIR G END:$D(DIRUT),GET78:'Y 8 D SITEP^FBAAUTL S FBO=$S($D(FBSITE(1)):$P(FBSITE(1),"^",7),1:""),FBNUM=$S($D(FBSITE(1)):$P(FBSITE(1),"^",5),1:"") 9 S FBT=$S($D(FBSITE(1)):$P(FBSITE(1),"^",8),1:"") 10 D FBO G END:$D(DIRUT) 11 S PRCF("X")="S" D ^PRCFSITE S PRC("SITE")=$S($D(PRC("SITE")):PRC("SITE"),1:"") I PRC("SITE")="" W ! G GET78 12 S FB("SITE")=PRC("SITE") 13 QUE S VAR="FB7078^FBNUM^FBO^FBT^FB(""SITE"")",VAL=FB7078_"^"_FBNUM_"^"_FBO_"^"_FBT_"^"_FB("SITE"),PGM="START^FBCHP78" D ZIS^FBAAUTL G:FBPOP END 14 ; 15 START S FB(0)=^FB7078(FB7078,0) S:$E(IOST,1,2)'["C-" FBPG=1 F FBM=1:1:FBNUM D 7078 16 END K DA,DFN,DIC,DINAME,DIRUT,DIWF,DIWL,DR,FB,FB7078,FBFD,FBID,FBNM,FBNUM,FBO,FBRR,FBSITE,FBTD,FBV,FBVEN,FBT,I,L,FBM,PGM,S,UL,VA,VADM,VAEL,VAERR,VAL,VAPA,VAR,X,Y,Z,PRC,PRCS,^UTILITY($J),PRCSCPAN 17 D CLOSE^FBAAUTL Q 18 ; 19 7078 U IO S UL="",$P(UL,"-",120)="-",L="|" D HED^FBCH78A 20 S DFN=$P(^FB7078(FB7078,0),"^",3) G END:'$D(DFN)#2!('$D(^DPT(+DFN,0))) 21 N FBNAME 22 S FBNAME("FILE")=2,FBNAME("IENS")=DFN_",",FBNAME("FIELD")=.01 23 S FBNAME=$$NAMEFMT^XLFNAME(.FBNAME,"F","C") 24 S VAPA("P")="" D SITEP^FBAAUTL,6^VADPT 25 N FBCONFAD S FBCONFAD=$$ACTIVECC^FBAACO0() I FBCONFAD,$L($G(VAPA(16))) D 26 . N FBLEN S FBLEN=$L(VAPA(16))+$L($P($G(VAPA(17)),U,2))+$L($P($G(VAPA(18)),U,2))+3 S:FBLEN>52 FBLEN=$L(VAPA(16))-(FBLEN-52),VAPA(16)=$E(VAPA(16),1,FBLEN) 27 F FBNM=1:1:7 S FBNM(FBNM)=$P(FBSITE(0),"^",FBNM) 28 S FBNM(5)=$S($D(^DIC(5,FBNM(5))):$P(^(FBNM(5),0),"^",2),1:"") 29 S Y=$P(FB(0),"^",10) D DATE S FBID=Y,FBVEN=$P(FB(0),"^",2),(FBVEN,FBV(0))=$P(FBVEN,";",1),FBVEN=$S($D(^FBAAV(FBVEN,0)):$P(^(0),"^",1),1:"Unknown"),FBVEN(1)=$S($D(^FBAAV(FBV(0),0)):$P(^(0),"^",2),1:"") 30 F I=3:1:6,14 S FBV(I)=$S($D(^FBAAV(FBV(0),0)):$P(^(0),"^",I),1:"") 31 I FBV(5)]"" S FBV(5)=$S($D(^DIC(5,FBV(5),0)):$P(^(0),"^",2),1:"") 32 S Y=$P(FB(0),"^",4) D DATE S FBFD=Y,Y=$S($P(FB(0),"^",5)]"":$P(FB(0),"^",5),1:"Disposition") D DATE:Y>0 S FBTD=Y 33 S FB(6)=$P(FB(0),"^",6) I FB(6)]"" S FB(6)=$S($D(^DIC(43.4,FB(6),0)):$P(^(0),"^",3),1:"") 34 W "Issuing Office",?66,L,"1. Date of Issue",!,?5,FBNM(1),?66,L,?70,FBID,!,?5,FBNM(2),?66,L,$E(UL,1,52),!,?5,$S(FBNM(3)]"":FBNM(3),1:FBNM(4)_", "_FBNM(5)_" "_FBNM(6)),?66,L,"2. Veteran's Name",! 35 I FBNM(3)]"" W ?5,FBNM(4)_", "_FBNM(5)_" "_FBNM(6) 36 W ?66,L,?70,FBNAME,!,UL,!,"Name of Physician or Station",?66,L,"3. Address",!,?5,FBVEN,?66,L,?68,$S(FBCONFAD:VAPA(13),1:VAPA(1)),!,?5,FBV(3),?66,L,?68,$S(FBCONFAD:VAPA(14),1:VAPA(2)),!,?5,FBV(14) 37 W ?66,L,?68,$S(FBCONFAD:VAPA(15),1:VAPA(3)),!?5,FBV(4)_", "_FBV(5)_" "_FBV(6) 38 W ?66,L,?68,$S(FBCONFAD:$G(VAPA(16)),1:VAPA(4))_", "_$S(FBCONFAD:$P($G(VAPA(17)),U,2),1:$P(VAPA(5),"^",2))_" "_$S(FBCONFAD:$P($G(VAPA(18)),U,2),'+$G(VAPA(11)):VAPA(6),$P(VAPA(11),U,2)]"":$P(VAPA(11),U,2),1:VAPA(6)),!?5,"ID#: ",FBVEN(1) 39 W ?66,L,$E(UL,1,53),!,?66,L,?68,"4. Veteran's Claim No.",?93,L,?95,"4A. SSN",!,?66,L,?68,VAEL(7),?93,L,?95,$$SSNL4^FBAAUTL($P(VADM(2),"^",2)),!,?66,L,$E(UL,1,53),!,?66,L,?75,"5. Authorization Valid",!,?66,L,$E(UL,1,53),! 40 ; next few lines contain changes that display/print the referring provider data FB*3.5*103 41 W "Name of VA Referring Provider",?66,L,"From",?93,L,"To",! 42 W ?5,$$GET1^DIQ(162.4,FB7078_",",15),?50,"NPI: ",$$REFNPI^FBCH78("",FB7078,1) 43 W ?66,L,?68,FBFD,?93,L,?95,FBTD,!,UL,!,?45,"PART 1. - SERVICES AUTHORIZED",!,UL,!,"6. Services shown below are authorized for the period indicated in Item 5 above.",?104,L,?107,"7. Fee",! 44 W ?12,"(See Special Provisions below.)",?104,L,"$",! 45 S DIWL=1,DIWF="WC103" K ^UTILITY($J,"W") 46 I $D(^FB7078(FB7078,1,0)) F FBRR=0:0 S FBRR=$O(^FB7078(FB7078,1,FBRR)) Q:FBRR'>0 S FBXX=^(FBRR,0),X=FBXX D ^DIWP 47 D ^DIWW:$D(FBXX) K FBXX 48 D FISCAL^FBCH78A 49 W UL,!,"8. Fee Schedule or Contract",?33,L,"9. Authority",?66,L,"9A.",?93,L,"10. Estimated Amount",!?5,$$CONT^FBCH78A(+$P(FB(0),U,2),$P(FB(0),U,4)),?33,L,?35,FB(6),?66,L,?93,L,?95,"$" 50 K X2 S X=$P(FB(0),"^",7),X3=$L(+X)+2 D COMMA^%DTC K X3 W X,!,UL,! 51 W "11. Fiscal Symbols",?66,L,"12. Authorized by (Name and Title)",!,?5,FB("SYM"),?66,L,?68,FBO," ",FBT,!,UL 52 D BOT^FBCH78A 53 Q 54 DATE S Y=$$FMTE^XLFDT(Y) Q 55 ; 56 FBO S DIR(0)="F^3:45",DIR("A")="Approving Official for 7078",DIR("B")=FBO,DIR("?")="Enter <return> to accept the default or enter a name from 3 to 45 characters in length" D ^DIR K DIR Q:$D(DIRUT) S FBO=X 57 FBT S DIR(0)="F^3:45",DIR("A")="Title of Approving Official",DIR("B")=FBT,DIR("?")="Enter <return> to accept the default title or enter a title from 3 to 45 characters in length" D ^DIR K DIR Q:$D(DIRUT) S FBT=X 58 ASKN S DIR(0)="N^1:5",DIR("A")="# of copies of 7078",DIR("B")=FBNUM,DIR("?")="Select a number between 1 and 5. This number represents the number of copies of the 7078 you would like printed" D ^DIR K DIR Q:$D(DIRUT) S FBNUM=X 1 FBCHP78 ;AISC/DMK-GENERATE 7078 ;7/NOV/2006 2 ;;3.5;FEE BASIS;**12,23,52,101**;JAN 30, 1995;Build 2 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 I '$D(^FBAA(161.4,1,0)) W !,"Site Parameters must be entered prior",!," to using this option." Q 5 GET78 S DIC="^FB7078(",DIC(0)="AEQMZ",DIC("A")="Select Veteran: ",D="D",DIC("S")="I $P(^(0),U,9)'=""DC""" D IX^DIC G END:X="^"!(X=""),GET78:Y<0 S FB7078=+Y,FB(0)=Y(0) K DIC,D 6 S DA=FB7078,DIC="^FB7078(",DR=0 D EN^DIQ 7 ASK S DIR(0)="Y",DIR("A")="Is this the correct 7078",DIR("B")="YES" D ^DIR K DIR G END:$D(DIRUT),GET78:'Y 8 D SITEP^FBAAUTL S FBO=$S($D(FBSITE(1)):$P(FBSITE(1),"^",7),1:""),FBNUM=$S($D(FBSITE(1)):$P(FBSITE(1),"^",5),1:"") 9 S FBT=$S($D(FBSITE(1)):$P(FBSITE(1),"^",8),1:"") 10 D FBO G END:$D(DIRUT) 11 S PRCF("X")="S" D ^PRCFSITE S PRC("SITE")=$S($D(PRC("SITE")):PRC("SITE"),1:"") I PRC("SITE")="" W ! G GET78 12 S FB("SITE")=PRC("SITE") 13 QUE S VAR="FB7078^FBNUM^FBO^FBT^FB(""SITE"")",VAL=FB7078_"^"_FBNUM_"^"_FBO_"^"_FBT_"^"_FB("SITE"),PGM="START^FBCHP78" D ZIS^FBAAUTL G:FBPOP END 14 ; 15 START S FB(0)=^FB7078(FB7078,0) S:$E(IOST,1,2)'["C-" FBPG=1 F FBM=1:1:FBNUM D 7078 16 END K DA,DFN,DIC,DINAME,DIRUT,DIWF,DIWL,DR,FB,FB7078,FBFD,FBID,FBNM,FBNUM,FBO,FBRR,FBSITE,FBTD,FBV,FBVEN,FBT,I,L,FBM,PGM,S,UL,VA,VADM,VAEL,VAERR,VAL,VAPA,VAR,X,Y,Z,PRC,PRCS,^UTILITY($J),PRCSCPAN 17 D CLOSE^FBAAUTL Q 18 ; 19 7078 U IO S UL="",$P(UL,"-",120)="-",L="|" D HED^FBCH78A 20 S DFN=$P(^FB7078(FB7078,0),"^",3) G END:'$D(DFN)#2!('$D(^DPT(+DFN,0))) 21 N FBNAME 22 S FBNAME("FILE")=2,FBNAME("IENS")=DFN_",",FBNAME("FIELD")=.01 23 S FBNAME=$$NAMEFMT^XLFNAME(.FBNAME,"F","C") 24 S VAPA("P")="" D SITEP^FBAAUTL,6^VADPT 25 N FBCONFAD S FBCONFAD=$$ACTIVECC^FBAACO0() I FBCONFAD,$L($G(VAPA(16))) D 26 . N FBLEN S FBLEN=$L(VAPA(16))+$L($P($G(VAPA(17)),U,2))+$L($P($G(VAPA(18)),U,2))+3 S:FBLEN>52 FBLEN=$L(VAPA(16))-(FBLEN-52),VAPA(16)=$E(VAPA(16),1,FBLEN) 27 F FBNM=1:1:7 S FBNM(FBNM)=$P(FBSITE(0),"^",FBNM) 28 S FBNM(5)=$S($D(^DIC(5,FBNM(5))):$P(^(FBNM(5),0),"^",2),1:"") 29 S Y=$P(FB(0),"^",10) D DATE S FBID=Y,FBVEN=$P(FB(0),"^",2),(FBVEN,FBV(0))=$P(FBVEN,";",1),FBVEN=$S($D(^FBAAV(FBVEN,0)):$P(^(0),"^",1),1:"Unknown"),FBVEN(1)=$S($D(^FBAAV(FBV(0),0)):$P(^(0),"^",2),1:"") 30 F I=3:1:6,14 S FBV(I)=$S($D(^FBAAV(FBV(0),0)):$P(^(0),"^",I),1:"") 31 I FBV(5)]"" S FBV(5)=$S($D(^DIC(5,FBV(5),0)):$P(^(0),"^",2),1:"") 32 S Y=$P(FB(0),"^",4) D DATE S FBFD=Y,Y=$S($P(FB(0),"^",5)]"":$P(FB(0),"^",5),1:"Disposition") D DATE:Y>0 S FBTD=Y 33 S FB(6)=$P(FB(0),"^",6) I FB(6)]"" S FB(6)=$S($D(^DIC(43.4,FB(6),0)):$P(^(0),"^",3),1:"") 34 W "Issuing Office",?66,L,"1. Date of Issue",!,?5,FBNM(1),?66,L,?70,FBID,!,?5,FBNM(2),?66,L,$E(UL,1,52),!,?5,$S(FBNM(3)]"":FBNM(3),1:FBNM(4)_", "_FBNM(5)_" "_FBNM(6)),?66,L,"2. Veteran's Name",! 35 I FBNM(3)]"" W ?5,FBNM(4)_", "_FBNM(5)_" "_FBNM(6) 36 W ?66,L,?70,FBNAME,!,UL,!,"Name of Physician or Station",?66,L,"3. Address",!,?5,FBVEN,?66,L,?68,$S(FBCONFAD:VAPA(13),1:VAPA(1)),!,?5,FBV(3),?66,L,?68,$S(FBCONFAD:VAPA(14),1:VAPA(2)),!,?5,FBV(14) 37 W ?66,L,?68,$S(FBCONFAD:VAPA(15),1:VAPA(3)),!?5,FBV(4)_", "_FBV(5)_" "_FBV(6) 38 W ?66,L,?68,$S(FBCONFAD:$G(VAPA(16)),1:VAPA(4))_", "_$S(FBCONFAD:$P($G(VAPA(17)),U,2),1:$P(VAPA(5),"^",2))_" "_$S(FBCONFAD:$P($G(VAPA(18)),U,2),'+$G(VAPA(11)):VAPA(6),$P(VAPA(11),U,2)]"":$P(VAPA(11),U,2),1:VAPA(6)),!?5,"ID#: ",FBVEN(1) 39 W ?66,L,$E(UL,1,53),!,?66,L,?68,"4. Veteran's Claim No.",?93,L,?95,"4A. SSN",!,?66,L,?68,VAEL(7),?93,L,?95,$$SSNL4^FBAAUTL($P(VADM(2),"^",2)),!,?66,L,$E(UL,1,53),!,?66,L,?75,"5. Authorization Valid",!,?66,L,$E(UL,1,53),! 40 W ?66,L,"From",?93,L,"To",!,?66,L,?68,FBFD,?93,L,?95,FBTD,!,UL,!,?45,"PART 1. - SERVICES AUTHORIZED",!,UL,!,"6. Services shown below are authorized for the period indicated in Item 5 above.",?104,L,?107,"7. Fee",! 41 W ?12,"(See Special Provisions below.)",?104,L,"$",! 42 S DIWL=1,DIWF="WC103" K ^UTILITY($J,"W") 43 I $D(^FB7078(FB7078,1,0)) F FBRR=0:0 S FBRR=$O(^FB7078(FB7078,1,FBRR)) Q:FBRR'>0 S FBXX=^(FBRR,0),X=FBXX D ^DIWP 44 D ^DIWW:$D(FBXX) K FBXX 45 D FISCAL^FBCH78A 46 W UL,!,"8. Fee Schedule or Contract",?33,L,"9. Authority",?66,L,"9A.",?93,L,"10. Estimated Amount",!?5,$$CONT^FBCH78A(+$P(FB(0),U,2),$P(FB(0),U,4)),?33,L,?35,FB(6),?66,L,?93,L,?95,"$" 47 K X2 S X=$P(FB(0),"^",7),X3=$L(+X)+2 D COMMA^%DTC K X3 W X,!,UL,! 48 W "11. Fiscal Symbols",?66,L,"12. Authorized by (Name and Title)",!,?5,FB("SYM"),?66,L,?68,FBO," ",FBT,!,UL 49 D BOT^FBCH78A 50 Q 51 DATE S Y=$$FMTE^XLFDT(Y) Q 52 ; 53 FBO S DIR(0)="F^3:45",DIR("A")="Approving Official for 7078",DIR("B")=FBO,DIR("?")="Enter <return> to accept the default or enter a name from 3 to 45 characters in length" D ^DIR K DIR Q:$D(DIRUT) S FBO=X 54 FBT S DIR(0)="F^3:45",DIR("A")="Title of Approving Official",DIR("B")=FBT,DIR("?")="Enter <return> to accept the default title or enter a title from 3 to 45 characters in length" D ^DIR K DIR Q:$D(DIRUT) S FBT=X 55 ASKN S DIR(0)="N^1:5",DIR("A")="# of copies of 7078",DIR("B")=FBNUM,DIR("?")="Select a number between 1 and 5. This number represents the number of copies of the 7078 you would like printed" D ^DIR K DIR Q:$D(DIRUT) S FBNUM=X -
WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBCHREQ1.m
r613 r623 1 FBCHREQ1 ;AISC/DMK-FEE NOTIFICATION CONT ;31AUG90 2 ;;3.5;FEE BASIS;**103**;JAN 30, 1995;Build 19 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 VENDOR ;ASK VENDOR FOR NOTIFICATION 5 W ! K FBCHVEN S DIC="^FBAAV(",DIC(0)="AEQLM",DLAYGO=161.2 D ^DIC G END:X=""!(X="^"),VENDOR:Y<0 S (DA,FBCHVEN)=+Y,DIE=DIC I $P(Y,"^",3)=1 S FBVENEW=1 D NEW^FBAAVD K DIC,DIE,DA,DLAYGO Q 6 ASKVOK I '$D(FBVENEW) D EN1^FBAAVD S DIR(0)="Y",DIR("A")="Is this the correct vendor",DIR("B")="YES" D ^DIR K DIR G VENDOR:$D(DIRUT)!'Y 7 END K DIC,DIE,DLAYGO 8 Q 9 TIMCK ;72 hour time check called from FBAA ENTER REQUEST template 10 S X1=$P(^FBAA(162.2,DA,0),"^",1),X=$P(^(0),"^",19),HY=Y,FBSW="" 11 S Y=$E(X1_"000",9,10)-$E(X_"000",9,10)*60+$E(X1_"00000",11,12)-$E(X_"00000",11,12),X2=X,X=$P(X,".",1)'=$P(X1,".",1) D ^%DTC:X S FBX=X*1440+Y 12 SURE I FBX>4320 W *7,!!,"This Authorization From Date exceeds the 72 hour notification period. ",!,?8,"Do you want to continue ? No// " R X:DTIME S:X="" X="N" G HELP:X["^" D VALCK^FBAAUTL1 G SURE:'VAL I "Nn"[$E(X,1) S FBSW=1,Y=HY Q 13 S Y=HY Q 14 HELP W !,"Entering an '^' is not allowed. Please answer 'Yes' or 'No'." G SURE 15 EN I $D(DA),DA S FBDA(0)=DA,DIE="^FBAA(162.2,",DR=".01////@" D ^DIE 16 I '$D(DA) W *7,!?3,"...request deleted",! I $D(^FBAA(161.5,FBDA(0),0)) S DA=FBDA(0),DIK="^FBAA(161.5," D ^DIK 17 K DIC,DIE,DIK,DA,X,FBDA,DR,DLAYGO,FBDATE,FBLG,FBN,FBUP,FBVT,VA D END^FBCHREQ 18 Q 19 EDIT ;EDIT A REQUEST THAT'S NOT COMPLETE 20 S DIC("S")="I $P(^(0),U,15)'=3" D ASKV^FBCHREQ K DIC("S") G Q:X=""!(X="^") S DA=+Y,FB(0)=^FBAA(162.2,DA,0),FBDOA=$P(FB(0),"^",19),FBFRDT=$P(FB(0),"^",5) 21 ; fb*3.5*103 add REFERRING PROVIDER (162.2,17) to DR string 22 S DIE="^FBAA(162.2,",DR="1;2;3.5;S:X=FBDOA!(X<FBFRDT) Y=""@10"";S FBDOA=X;4////^S X=FBDOA;I 1;@10;4;5;17;I $G(X) W !,""REFERRING PROVIDER NPI: "",$$REFNPI^FBCH78(X);6;S FBCHVEN=X" D ^DIE S FBN(0)=^FBAA(162.2,DA,0) 23 I FB(0)'=FBN(0) S DR="7////^S X=DUZ" D ^DIE 24 I $D(DA),$D(^FBAA(161.5,DA,0)) D 25 .I FB(0)'=FBN(0) S $P(^FBAA(161.5,DA,0),"^",2)=$P(FBN(0),"^",2),$P(^(0),"^",5)=$P(FBN(0),"^",5),$P(^FBAA(161.5,DA,1),"^",7)=$P(FBN(0),"^",19),$P(^(1),U)=$P(FBN(0),U,6),DIK="^FBAA(161.5," D IX^DIK K DIK 26 .S FBREQED=1,DIC="^FBAA(161.5,",DIC(0)="AEQM" D EN^FBCHROC 27 Q K DIE,DIC,DIRUT,DUOUT,DTOUT,X,Y,DR,FB,FBN,FBDA,FBDFN,FBNAME,FBSSN,DA,FBCHVEN,FBREQED,FBDOA,FBFRDT,J 28 Q 29 DATCK ;Verify authorized from date is > or = date of admission. 30 S FBDOA=$P(^FBAA(162.2,DA,0),"^",19) I $G(FBDOA),X<FBDOA W !,*7,"Authorized From Date must be equal to or greater than the Date of Admission" S FBOUT=1 31 Q 1 FBCHREQ1 ;AISC/DMK-FEE NOTIFICATION CONT ;31AUG90 2 ;;3.5;FEE BASIS;;JAN 30, 1995 3 ;;Per VHA Directive 10-93-142, this routine should not be modified. 4 VENDOR ;ASK VENDOR FOR NOTIFICATION 5 W ! K FBCHVEN S DIC="^FBAAV(",DIC(0)="AEQLM",DLAYGO=161.2 D ^DIC G END:X=""!(X="^"),VENDOR:Y<0 S (DA,FBCHVEN)=+Y,DIE=DIC I $P(Y,"^",3)=1 S FBVENEW=1 D NEW^FBAAVD K DIC,DIE,DA,DLAYGO Q 6 ASKVOK I '$D(FBVENEW) D EN1^FBAAVD S DIR(0)="Y",DIR("A")="Is this the correct vendor",DIR("B")="YES" D ^DIR K DIR G VENDOR:$D(DIRUT)!'Y 7 END K DIC,DIE,DLAYGO 8 Q 9 TIMCK ;72 hour time check called from FBAA ENTER REQUEST template 10 S X1=$P(^FBAA(162.2,DA,0),"^",1),X=$P(^(0),"^",19),HY=Y,FBSW="" 11 S Y=$E(X1_"000",9,10)-$E(X_"000",9,10)*60+$E(X1_"00000",11,12)-$E(X_"00000",11,12),X2=X,X=$P(X,".",1)'=$P(X1,".",1) D ^%DTC:X S FBX=X*1440+Y 12 SURE I FBX>4320 W *7,!!,"This Authorization From Date exceeds the 72 hour notification period. ",!,?8,"Do you want to continue ? No// " R X:DTIME S:X="" X="N" G HELP:X["^" D VALCK^FBAAUTL1 G SURE:'VAL I "Nn"[$E(X,1) S FBSW=1,Y=HY Q 13 S Y=HY Q 14 HELP W !,"Entering an '^' is not allowed. Please answer 'Yes' or 'No'." G SURE 15 EN I $D(DA),DA S FBDA(0)=DA,DIE="^FBAA(162.2,",DR=".01////@" D ^DIE 16 I '$D(DA) W *7,!?3,"...request deleted",! I $D(^FBAA(161.5,FBDA(0),0)) S DA=FBDA(0),DIK="^FBAA(161.5," D ^DIK 17 K DIC,DIE,DIK,DA,X,FBDA,DR,DLAYGO,FBDATE,FBLG,FBN,FBUP,FBVT,VA D END^FBCHREQ 18 Q 19 EDIT ;EDIT A REQUEST THAT'S NOT COMPLETE 20 S DIC("S")="I $P(^(0),U,15)'=3" D ASKV^FBCHREQ K DIC("S") G Q:X=""!(X="^") S DA=+Y,FB(0)=^FBAA(162.2,DA,0),FBDOA=$P(FB(0),"^",19),FBFRDT=$P(FB(0),"^",5) 21 S DIE="^FBAA(162.2,",DR="1;2;3.5;S:X=FBDOA!(X<FBFRDT) Y=""@10"";S FBDOA=X;4////^S X=FBDOA;I 1;@10;4:6;S FBCHVEN=X" D ^DIE S FBN(0)=^FBAA(162.2,DA,0) 22 I FB(0)'=FBN(0) S DR="7////^S X=DUZ" D ^DIE 23 I $D(DA),$D(^FBAA(161.5,DA,0)) D 24 .I FB(0)'=FBN(0) S $P(^FBAA(161.5,DA,0),"^",2)=$P(FBN(0),"^",2),$P(^(0),"^",5)=$P(FBN(0),"^",5),$P(^FBAA(161.5,DA,1),"^",7)=$P(FBN(0),"^",19),$P(^(1),U)=$P(FBN(0),U,6),DIK="^FBAA(161.5," D IX^DIK K DIK 25 .S FBREQED=1,DIC="^FBAA(161.5,",DIC(0)="AEQM" D EN^FBCHROC 26 Q K DIE,DIC,DIRUT,DUOUT,DTOUT,X,Y,DR,FB,FBN,FBDA,FBDFN,FBNAME,FBSSN,DA,FBCHVEN,FBREQED,FBDOA,FBFRDT,J 27 Q 28 DATCK ;Verify authorized from date is > or = date of admission. 29 S FBDOA=$P(^FBAA(162.2,DA,0),"^",19) I $G(FBDOA),X<FBDOA W !,*7,"Authorized From Date must be equal to or greater than the Date of Admission" S FBOUT=1 30 Q -
WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBCTAU.m
r613 r623 1 FBCTAU ; GENERATED FROM 'FBAA AUTHORIZATION' INPUT TEMPLATE(#1015), FILE 161; 11/08/091 FBCTAU ; GENERATED FROM 'FBAA AUTHORIZATION' INPUT TEMPLATE(#1015), FILE 161;06/28/03 2 2 D DE G BEGIN 3 3 DE S DIE="^FBAAA(",DIC=DIE,DP=161,DL=1,DIEL=0,DU="" K DG,DE,DB Q:$O(^FBAAA(DA,""))="" … … 57 57 Q 58 58 2 S D=0 K DE(1) ;1 59 S DIFLD=1,DGO="^FBCTAU1",DC="2 3^161.01ID^1^",DV="161.01DX",DW="0;1",DOW="FROM DATE",DLB="Select "_DOW S:D DC=DC_D59 S DIFLD=1,DGO="^FBCTAU1",DC="22^161.01ID^1^",DV="161.01DX",DW="0;1",DOW="FROM DATE",DLB="Select "_DOW S:D DC=DC_D 60 60 I $D(DSC(161.01))#2,$P(DSC(161.01),"I $D(^UTILITY(",1)="" X DSC(161.01) S D=$O(^(0)) S:D="" D=-1 G M2 61 61 S D=$S($D(^FBAAA(DA,1,0)):$P(^(0),U,3,4),$O(^(0))'="":$O(^(0)),1:-1) -
WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBCTAU1.m
r613 r623 1 FBCTAU1 ; ; 11/08/091 FBCTAU1 ; ;06/28/03 2 2 D DE G BEGIN 3 3 DE S DIE="^FBAAA(D0,1,",DIC=DIE,DP=161.01,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^FBAAA(D0,1,DA,""))="" 4 I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,1) S:%]"" DE(4)=%,DE(8)=% S %=$P(%Z,U,2) S:%]"" DE(14)=% S %=$P(%Z,U,3) S:%]"" DE(16)=% S %=$P(%Z,U,5) S:%]"" DE(18)=% S %=$P(%Z,U,7) S:%]"" DE(22)=% S %=$P(%Z,U,13) S:%]"" DE(30)=% 5 I S %=$P(%Z,U,18) S:%]"" DE(29)=% S %=$P(%Z,U,21) S:%]"" DE(19)=% 4 I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,1) S:%]"" DE(4)=%,DE(8)=% S %=$P(%Z,U,2) S:%]"" DE(14)=% S %=$P(%Z,U,3) S:%]"" DE(16)=% S %=$P(%Z,U,5) S:%]"" DE(18)=% S %=$P(%Z,U,7) S:%]"" DE(20)=% 6 5 K %Z Q 7 6 ; … … 171 170 G RE 172 171 X18 Q 173 19 S DW="0;21",DV="*P200'",DU="",DLB="REFERRING PROVIDER",DIFLD=104 174 S DU="VA(200," 172 19 S DQ=20 ;@4 173 20 S DW="0;7",DV="R*P161.82'",DU="",DLB="PURPOSE OF VISIT CODE",DIFLD=.07 174 S DU="FBAA(161.82," 175 175 G RE 176 X 19 S DIC("S")="I $$PROVIDER^FBAAAUT(+Y)" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X176 X20 S DIC("S")="I $S('$G(^(""I"")):1,DT'>^(""I""):1,1:0),$S('$D(FBTYPE):1,$P(^(0),U,2)=FBTYPE:1,1:0)" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X 177 177 Q 178 178 ; 179 2 0 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=20 D X20D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17180 X2 0 I $G(X) W !,"REFERRING PROVIDER NPI: ",$$REFNPI^FBCH78(X)179 21 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=21 D X21 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 180 X21 S:$$EXTPV^FBAAUTL5(X)'=55 Y="@5" 181 181 Q 182 21 S DQ=22 ;@4 183 22 S DW="0;7",DV="R*P161.82'",DU="",DLB="PURPOSE OF VISIT CODE",DIFLD=.07 184 S DU="FBAA(161.82," 185 G RE 186 X22 S DIC("S")="I $S('$G(^(""I"")):1,DT'>^(""I""):1,1:0),$S('$D(FBTYPE):1,$P(^(0),U,2)=FBTYPE:1,1:0)" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X 182 22 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=22 D X22 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 183 X22 S:$P($$GETSTAT^DGMSTAPI(DA(1)),U,2)="Y" Y="@5" 187 184 Q 188 ;189 185 23 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=23 D X23 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 190 X23 S :$$EXTPV^FBAAUTL5(X)'=55 Y="@5"186 X23 S DIE("NO^")="" 191 187 Q 192 188 24 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=24 D X24 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 193 X24 S:$P($$GETSTAT^DGMSTAPI(DA(1)),U,2)="Y" Y="@5"189 X24 W !,$C(7),"MST POV can't be selected because veteran's MST status is not YES." 194 190 Q 195 191 25 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=25 D X25 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 196 X25 S DIE("NO^")=""192 X25 S Y="@4" 197 193 Q 198 26 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=26 D X26 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 199 X26 W !,$C(7),"MST POV can't be selected because veteran's MST status is not YES." 200 Q 201 27 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=27 D X27 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 202 X27 S Y="@4" 203 Q 204 28 S DQ=29 ;@5 205 29 S DW="0;18",DV="S",DU="",DLB="PATIENT TYPE CODE",DIFLD=.065 206 S DU="00:SURGICAL;10:MEDICAL;60:HOME NURSING SERVICE;85:PSYCHIATRIC-CONTRACT;86:PSYCHIATRIC;95:NEUROLOGICAL-CONTRACT;96:NEUROLOGICAL;" 207 G RE 208 X29 Q 209 30 S DW="0;13",DV="R*S",DU="",DLB="TREATMENT TYPE CODE",DIFLD=.095 210 S DE(DW)="C30^FBCTAU1" 211 S DU="1:SHORT TERM FEE STATUS;2:HOME NURSING SERVICES;3:I.D. CARD STATUS;4:STATE HOME;" 212 G RE 213 C30 G C30S:$D(DE(30))[0 K DB 214 S X=DE(30),DIC=DIE 215 ; 216 C30S S X="" G:DG(DQ)=X C30F1 K DB 217 D ^FBCTAU2 218 C30F1 Q 219 X30 Q 220 31 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=31 D X31 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 221 X31 S FBAATT=X 222 Q 223 32 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=32 D X32 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 224 X32 S FBAALT=$S(X=2:"Y",X=3:"Y",1:"") 225 Q 226 33 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=33 D X33 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 227 X33 K DIE("NO^") 228 Q 229 34 D:$D(DG)>9 F^DIE17 G ^FBCTAU3 194 26 S DQ=27 ;@5 195 27 D:$D(DG)>9 F^DIE17 G ^FBCTAU2 -
WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBCTAU2.m
r613 r623 1 FBCTAU2 ; ;11/08/09 1 FBCTAU2 ; ;06/28/03 2 D DE G BEGIN 3 DE S DIE="^FBAAA(D0,1,",DIC=DIE,DP=161.01,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^FBAAA(D0,1,DA,""))="" 4 I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,4) S:%]"" DE(15)=% S %=$P(%Z,U,8) S:%]"" DE(6)=% S %=$P(%Z,U,13) S:%]"" DE(2)=% S %=$P(%Z,U,14) S:%]"" DE(12)=% S %=$P(%Z,U,18) S:%]"" DE(1)=% S %=$P(%Z,U,19) S:%]"" DE(19)=% S %=$P(%Z,U,20) S:%]"" DE(20)=% 5 I $D(^(3)) S %Z=^(3) S %=$P(%Z,U,1) S:%]"" DE(8)=% S %=$P(%Z,U,2) S:%]"" DE(10)=% 6 I $D(^(100)) S %Z=^(100) S %=$P(%Z,U,1) S:%]"" DE(17)=% 7 I $D(^("C")) S %Z=^("C") S %=$P(%Z,U,1) S:%]"" DE(21)=%,DE(24)=% 8 K %Z Q 9 ; 10 W W !?DL+DL-2,DLB_": " 11 Q 12 O D W W Y W:$X>45 !?9 13 I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2 14 W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W " (No Editing)" Q 15 TR R X:DTIME E S (DTOUT,X)=U W $C(7) 16 Q 17 A K DQ(DQ) S DQ=DQ+1 18 B G @DQ 19 RE G PR:$D(DE(DQ)) D W,TR 20 N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A 21 RD G QS:X?."?" I X["^" D D G ^DIE17 22 I X="@" D D G Z^DIE2 23 I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W " "_X 24 T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I W:'$D(DB(DQ)) " "_% G V 25 K DDER G X 26 P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0 27 G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z 28 I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X 29 V D @("X"_DQ) K YS 30 Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A 31 X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17 32 S X="?BAD" 33 QS S DZ=X D D,QQ^DIEQ G B 34 D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q 35 Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N 36 PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP 37 R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R 38 I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R 39 X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=% 40 RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17 41 I I DV'["I",DV'["#" G RD 42 D E^DIE0 G RD:$D(X),PR 43 Q 44 SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1 45 I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1 46 D ^DIR I 'DDER S %=Y(0),X=Y 47 Q 48 SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ)) 49 I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")="" 50 E K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/") 51 Q 52 NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G QS 53 KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") 54 BEGIN S DNM="FBCTAU2",DQ=1 55 1 S DW="0;18",DV="S",DU="",DLB="PATIENT TYPE CODE",DIFLD=.065 56 S DU="00:SURGICAL;10:MEDICAL;60:HOME NURSING SERVICE;85:PSYCHIATRIC-CONTRACT;86:PSYCHIATRIC;95:NEUROLOGICAL-CONTRACT;96:NEUROLOGICAL;" 57 G RE 58 X1 Q 59 2 S DW="0;13",DV="R*S",DU="",DLB="TREATMENT TYPE CODE",DIFLD=.095 60 S DE(DW)="C2^FBCTAU2" 61 S DU="1:SHORT TERM FEE STATUS;2:HOME NURSING SERVICES;3:I.D. CARD STATUS;4:STATE HOME;" 62 G RE 63 C2 G C2S:$D(DE(2))[0 K DB 64 S X=DE(2),DIC=DIE 65 ; 66 C2S S X="" G:DG(DQ)=X C2F1 K DB 2 67 S X=DG(DQ),DIC=DIE 3 68 D:'$D(DIU(0)) EVENT^IVMPLOG(DA(1)) 69 C2F1 Q 70 X2 Q 71 3 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=3 D X3 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 72 X3 S FBAATT=X 73 Q 74 4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 75 X4 S FBAALT=$S(X=2:"Y",X=3:"Y",1:"") 76 Q 77 5 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=5 D X5 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 78 X5 K DIE("NO^") 79 Q 80 6 D:$D(DG)>9 F^DIE17,DE S DQ=6,DW="0;8",DV="F",DU="",DLB="DX LINE 1",DIFLD=.08 81 G RE 82 X6 K:$L(X)>60!($L(X)<3) X 83 I $D(X),X'?.ANP K X 84 Q 85 ; 86 7 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=7 D X7 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 87 X7 S:X="" Y=.021 88 Q 89 8 S DW="3;1",DV="F",DU="",DLB="DX LINE 2",DIFLD=.085 90 G RE 91 X8 K:$L(X)>60!($L(X)<2) X 92 I $D(X),X'?.ANP K X 93 Q 94 ; 95 9 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=9 D X9 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 96 X9 S:X="" Y=.021 97 Q 98 10 S DW="3;2",DV="F",DU="",DLB="DX LINE 3",DIFLD=.086 99 G RE 100 X10 K:$L(X)>60!($L(X)<2) X 101 I $D(X),X'?.ANP K X 102 Q 103 ; 104 11 S D=0 K DE(1) ;.021 105 S Y="AUTHORIZATION REMARKS^W^^0;1^Q",DG="2",DC="^161.06" D DIEN^DIWE K DE(1) G A 106 ; 107 12 S DW="0;14",DV="S",DU="",DLB="TYPE OF CARE",DIFLD=2 108 S DU="1:C&P;2:OPT NSC;3:OPT SC;" 109 G RE 110 X12 Q 111 13 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=13 D X13 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 112 X13 S:'$D(FBAAASKV) FBAAASKV="N" 113 Q 114 14 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=14 D X14 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 115 X14 S:FBAAASKV'="y" Y=100 116 Q 117 15 S DW="0;4",DV="P161.2",DU="",DLB="VENDOR",DIFLD=.04 118 S DE(DW)="C15^FBCTAU2" 119 S DU="FBAAV(" 120 G RE 121 C15 G C15S:$D(DE(15))[0 K DB 122 S X=DE(15),DIC=DIE 123 K ^FBAAA("ACV",$E(X,1,30),DA(1),DA) 124 C15S S X="" G:DG(DQ)=X C15F1 K DB 125 S X=DG(DQ),DIC=DIE 126 S ^FBAAA("ACV",$E(X,1,30),DA(1),DA)="" 127 C15F1 Q 128 X15 Q 129 16 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=16 G A 130 17 D:$D(DG)>9 F^DIE17,DE S DQ=17,DW="100;1",DV="P200'",DU="",DLB="CLERK",DIFLD=100 131 S DU="VA(200," 132 S X=DUZ 133 S Y=X 134 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 135 G RD:X="@",Z 136 X17 Q 137 18 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=18 D X18 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 138 X18 W !! 139 Q 140 19 S DW="0;19",DV="FXO",DU="",DLB="ACCIDENT RELATED (Y/N)",DIFLD=.096 141 S DQ(19,2)="S Y(0)=Y D OUTYN^FBAAUTL3" 142 S DE(DW)="C19^FBCTAU2" 143 G RE 144 C19 G C19S:$D(DE(19))[0 K DB 145 S X=DE(19),DIC=DIE 146 K ^FBAAA("AA",X,$P(^FBAAA(DA(1),1,DA,0),U,1),DA(1),DA) 147 C19S S X="" G:DG(DQ)=X C19F1 K DB 148 S X=DG(DQ),DIC=DIE 149 S ^FBAAA("AA",X,$P(^FBAAA(DA(1),1,DA,0),U,1),DA(1),DA)="" 150 C19F1 Q 151 X19 I $D(X) D YN^FBAAUTL3 152 I $D(X),X'?.ANP K X 153 Q 154 ; 155 20 D:$D(DG)>9 F^DIE17,DE S DQ=20,DW="0;20",DV="RFXO",DU="",DLB="POTENTIAL COST RECOVERY CASE",DIFLD=.097 156 S DQ(20,2)="S Y(0)=Y D OUTYN^FBAAUTL3" 157 S DE(DW)="C20^FBCTAU2" 158 S X="NO" 159 S Y=X 160 G Y 161 C20 G C20S:$D(DE(20))[0 K DB 162 S X=DE(20),DIC=DIE 163 K ^FBAAA("AC",X,$P(^FBAAA(DA(1),1,DA,0),U,1),DA(1),DA) 164 S X=DE(20),DIC=DIE 165 K:$P(^FBAAA(DA(1),1,DA,0),U) ^FBAAA("AIC",DA(1),-($P(^FBAAA(DA(1),1,DA,0),U)),X,DA) 166 C20S S X="" G:DG(DQ)=X C20F1 K DB 167 S X=DG(DQ),DIC=DIE 168 S ^FBAAA("AC",X,$P(^FBAAA(DA(1),1,DA,0),U,1),DA(1),DA)="" 169 S X=DG(DQ),DIC=DIE 170 S:$P(^FBAAA(DA(1),1,DA,0),U) ^FBAAA("AIC",DA(1),-($P(^FBAAA(DA(1),1,DA,0),U)),X,DA)="" 171 C20F1 Q 172 X20 I $D(X) D YN^FBAAUTL3 173 I $D(X),X'?.ANP K X 174 Q 175 ; 176 21 D:$D(DG)>9 F^DIE17,DE S DQ=21,DW="C;1",DV="FX",DU="",DLB="PRINT AUTHORIZATION (Y/N)",DIFLD=1 177 S DE(DW)="C21^FBCTAU2" 178 S X="YES" 179 S Y=X 180 G Y 181 C21 G C21S:$D(DE(21))[0 K DB 182 S X=DE(21),DIC=DIE 183 D KILL^FBAAUTL2 184 C21S S X="" G:DG(DQ)=X C21F1 K DB 185 S X=DG(DQ),DIC=DIE 186 D ADD^FBAAUTL2 187 C21F1 Q 188 X21 I $D(X) D YN^FBAAUTL3 189 I $D(X),X'?.ANP K X 190 Q 191 ; 192 22 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=22 D X22 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 193 X22 S FBAAP79=$S(X["Y":"Y",1:"") 194 Q 195 23 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=23 D X23 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 196 X23 I X["Y" S Y="" 197 Q 198 24 D:$D(DG)>9 F^DIE17,DE S DQ=24,DW="C;1",DV="FX",DU="",DLB="PRINT AUTHORIZATION (Y/N)",DIFLD=1 199 S DE(DW)="C24^FBCTAU2" 200 S X="@" 201 S Y=X 202 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 203 G RD 204 C24 G C24S:$D(DE(24))[0 K DB 205 D ^FBCTAU3 206 C24S S X="" G:DG(DQ)=X C24F1 K DB 207 D ^FBCTAU4 208 C24F1 Q 209 X24 I $D(X) D YN^FBAAUTL3 210 I $D(X),X'?.ANP K X 211 Q 212 ; 213 25 G 1^DIE17 -
WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBCTAU3.m
r613 r623 1 FBCTAU3 ; ;11/08/09 2 D DE G BEGIN 3 DE S DIE="^FBAAA(D0,1,",DIC=DIE,DP=161.01,DL=2,DIEL=1,DU="" K DG,DE,DB Q:$O(^FBAAA(D0,1,DA,""))="" 4 I $D(^(0)) S %Z=^(0) S %=$P(%Z,U,4) S:%]"" DE(10)=% S %=$P(%Z,U,8) S:%]"" DE(1)=% S %=$P(%Z,U,14) S:%]"" DE(7)=% S %=$P(%Z,U,19) S:%]"" DE(14)=% S %=$P(%Z,U,20) S:%]"" DE(15)=% 5 I $D(^(3)) S %Z=^(3) S %=$P(%Z,U,1) S:%]"" DE(3)=% S %=$P(%Z,U,2) S:%]"" DE(5)=% 6 I $D(^(100)) S %Z=^(100) S %=$P(%Z,U,1) S:%]"" DE(12)=% 7 I $D(^("C")) S %Z=^("C") S %=$P(%Z,U,1) S:%]"" DE(16)=%,DE(19)=% 8 K %Z Q 9 ; 10 W W !?DL+DL-2,DLB_": " 11 Q 12 O D W W Y W:$X>45 !?9 13 I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2 14 W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W " (No Editing)" Q 15 TR R X:DTIME E S (DTOUT,X)=U W $C(7) 16 Q 17 A K DQ(DQ) S DQ=DQ+1 18 B G @DQ 19 RE G PR:$D(DE(DQ)) D W,TR 20 N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A 21 RD G QS:X?."?" I X["^" D D G ^DIE17 22 I X="@" D D G Z^DIE2 23 I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W " "_X 24 T G M^DIE17:DV,^DIE3:DV["V",P:DV'["S" X:$D(^DD(DP,DIFLD,12.1)) ^(12.1) I X?.ANP D SET I 'DDER X:$D(DIC("S")) DIC("S") I W:'$D(DB(DQ)) " "_% G V 25 K DDER G X 26 P I DV["P" S DIC=U_DU,DIC(0)=$E("EN",$D(DB(DQ))+1)_"M"_$E("L",DV'["'") S:DIC(0)["L" DLAYGO=+$P(DV,"P",2) G:DV["*" AST^DIED D NOSCR^DIED S X=+Y,DIC=DIE G X:X<0 27 G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z 28 I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X 29 V D @("X"_DQ) K YS 30 Z K DIC("S"),DLAYGO I $D(X),X'=U D:$G(DE(DW,"INDEX")) SAVEVALS G:'$$KEYCHK UNIQFERR^DIE17 S DG(DW)=X S:DV["d" ^DISV(DUZ,"DIE",DLB)=X G A 31 X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17 32 S X="?BAD" 33 QS S DZ=X D D,QQ^DIEQ G B 34 D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q 35 Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N 36 PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP 37 R I DG["P",@("$D(^"_X_"0))") S X=+$P(^(0),U,2) G RP:'$D(^(Y,0)) S Y=$P(^(0),U),X=$P(^DD(X,.01,0),U,3),DG=$P(^(0),U,2) G R 38 I DG["V",+Y,$P(Y,";",2)["(",$D(@(U_$P(Y,";",2)_"0)")) S X=+$P(^(0),U,2) G RP:'$D(^(+Y,0)) S Y=$P(^(0),U) I $D(^DD(+X,.01,0)) S DG=$P(^(0),U,2),X=$P(^(0),U,3) G R 39 X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=% 40 RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17 41 I I DV'["I",DV'["#" G RD 42 D E^DIE0 G RD:$D(X),PR 43 Q 44 SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1 45 I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1 46 D ^DIR I 'DDER S %=Y(0),X=Y 47 Q 48 SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ)) 49 I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")="" 50 E K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/") 51 Q 52 NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G QS 53 KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") 54 BEGIN S DNM="FBCTAU3",DQ=1 55 1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW="0;8",DV="F",DU="",DLB="DX LINE 1",DIFLD=.08 56 G RE 57 X1 K:$L(X)>60!($L(X)<3) X 58 I $D(X),X'?.ANP K X 59 Q 60 ; 61 2 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=2 D X2 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 62 X2 S:X="" Y=.021 63 Q 64 3 S DW="3;1",DV="F",DU="",DLB="DX LINE 2",DIFLD=.085 65 G RE 66 X3 K:$L(X)>60!($L(X)<2) X 67 I $D(X),X'?.ANP K X 68 Q 69 ; 70 4 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=4 D X4 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 71 X4 S:X="" Y=.021 72 Q 73 5 S DW="3;2",DV="F",DU="",DLB="DX LINE 3",DIFLD=.086 74 G RE 75 X5 K:$L(X)>60!($L(X)<2) X 76 I $D(X),X'?.ANP K X 77 Q 78 ; 79 6 S D=0 K DE(1) ;.021 80 S Y="AUTHORIZATION REMARKS^W^^0;1^Q",DG="2",DC="^161.06" D DIEN^DIWE K DE(1) G A 81 ; 82 7 S DW="0;14",DV="S",DU="",DLB="TYPE OF CARE",DIFLD=2 83 S DU="1:C&P;2:OPT NSC;3:OPT SC;" 84 G RE 85 X7 Q 86 8 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=8 D X8 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 87 X8 S:'$D(FBAAASKV) FBAAASKV="N" 88 Q 89 9 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=9 D X9 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 90 X9 S:FBAAASKV'="y" Y=100 91 Q 92 10 S DW="0;4",DV="P161.2",DU="",DLB="VENDOR",DIFLD=.04 93 S DE(DW)="C10^FBCTAU3" 94 S DU="FBAAV(" 95 G RE 96 C10 G C10S:$D(DE(10))[0 K DB 97 S X=DE(10),DIC=DIE 98 K ^FBAAA("ACV",$E(X,1,30),DA(1),DA) 99 C10S S X="" G:DG(DQ)=X C10F1 K DB 100 S X=DG(DQ),DIC=DIE 101 S ^FBAAA("ACV",$E(X,1,30),DA(1),DA)="" 102 C10F1 Q 103 X10 Q 104 11 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=11 G A 105 12 D:$D(DG)>9 F^DIE17,DE S DQ=12,DW="100;1",DV="P200'",DU="",DLB="CLERK",DIFLD=100 106 S DU="VA(200," 107 S X=DUZ 108 S Y=X 109 S X=Y,DB(DQ)=1,DE(DW,"4/")="" G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X) 110 G RD:X="@",Z 111 X12 Q 112 13 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=13 D X13 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17 113 X13 W !! 114 Q 115 14 S DW="0;19",DV="FXO",DU="",DLB="ACCIDENT RELATED (Y/N)",DIFLD=.096 116 S DQ(14,2)="S Y(0)=Y D OUTYN^FBAAUTL3" 117 S DE(DW)="C14^FBCTAU3" 118 G RE 119 C14 G C14S:$D(DE(14))[0 K DB 120 S X=DE(14),DIC=DIE 121 K ^FBAAA("AA",X,$P(^FBAAA(DA(1),1,DA,0),U,1),DA(1),DA) 122 C14S S X="" G:DG(DQ)=X C14F1 K DB 123 S X=DG(DQ),DIC=DIE 124 S ^FBAAA("AA",X,$P(^FBAAA(DA(1),1,DA,0),U,1),DA(1),DA)="" 125 C14F1 Q 126 X14 I $D(X) D YN^FBAAUTL3 127 I $D(X),X'?.ANP K X 128 Q 129 ; 130 15 D:$D(DG)>9 F^DIE17,DE S DQ=15,DW="0;20",DV="RFXO",DU="",DLB="POTENTIAL COST RECOVERY CASE",DIFLD=.097 131 S DQ(15,2)="S Y(0)=Y D OUTYN^FBAAUTL3" 132 S DE(DW)="C15^FBCTAU3" 133 S X="NO" 134 S Y=X 135 G Y 136 C15 G C15S:$D(DE(15))[0 K DB 137 S X=DE(15),DIC=DIE 138 K ^FBAAA("AC",X,$P(^FBAAA(DA(1),1,DA,0),U,1),DA(1),DA) 139 S X=DE(15),DIC=DIE 140 K:$P(^FBAAA(DA(1),1,DA,0),U) ^FBAAA("AIC",DA(1),-($P(^FBAAA(DA(1),1,DA,0),U)),X,DA) 141 C15S S X="" G:DG(DQ)=X C15F1 K DB 142 S X=DG(DQ),DIC=DIE 143 S ^FBAAA("AC",X,$P(^FBAAA(DA(1),1,DA,0),U,1),DA(1),DA)="" 144 S X=DG(DQ),DIC=DIE 145 S:$P(^FBAAA(DA(1),1,DA,0),U) ^FBAAA("AIC",DA(1),-($P(^FBAAA(DA(1),1,DA,0),U)),X,DA)="" 146 C15F1 Q 147 X15 I $D(X) D YN^FBAAUTL3 148 I $D(X),X'?.ANP K X 149 Q 150 ; 151 16 D:$D(DG)>9 F^DIE17,DE S DQ=16,DW="C;1",DV="FX",DU="",DLB="PRINT AUTHORIZATION (Y/N)",DIFLD=1 152 S DE(DW)="C16^FBCTAU3" 153 S X="YES" 154 S Y=X 155 G Y 156 C16 G C16S:$D(DE(16))[0 K DB 157 S X=DE(16),DIC=DIE 1 FBCTAU3 ; ;06/28/03 2 S X=DE(24),DIC=DIE 158 3 D KILL^FBAAUTL2 159 C16S S X="" G:DG(DQ)=X C16F1 K DB160 S X=DG(DQ),DIC=DIE161 D ADD^FBAAUTL2162 C16F1 Q163 X16 I $D(X) D YN^FBAAUTL3164 I $D(X),X'?.ANP K X165 Q166 ;167 17 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=17 D X17 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17168 X17 S FBAAP79=$S(X["Y":"Y",1:"")169 Q170 18 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=18 D X18 D:$D(DIEFIRE)#2 FIREREC^DIE17 G A:$D(Y)[0,A:Y=U S X=Y,DIC(0)="F",DW=DQ G OUT^DIE17171 X18 I X["Y" S Y=""172 Q173 19 D:$D(DG)>9 F^DIE17,DE S DQ=19,DW="C;1",DV="FX",DU="",DLB="PRINT AUTHORIZATION (Y/N)",DIFLD=1174 S DE(DW)="C19^FBCTAU3"175 S X="@"176 S Y=X177 S X=Y,DB(DQ)=1 G:X="" N^DIE17:DV,A I $D(DE(DQ)),DV["I"!(DV["#") D E^DIE0 G A:'$D(X)178 G RD179 C19 G C19S:$D(DE(19))[0 K DB180 S X=DE(19),DIC=DIE181 D KILL^FBAAUTL2182 C19S S X="" G:DG(DQ)=X C19F1 K DB183 S X=DG(DQ),DIC=DIE184 D ADD^FBAAUTL2185 C19F1 Q186 X19 I $D(X) D YN^FBAAUTL3187 I $D(X),X'?.ANP K X188 Q189 ;190 20 G 1^DIE17 -
WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBNHEAU1.m
r613 r623 1 FBNHEAU1 ;AISC/dmk - continue FBNHEAUT cnh authorization ;4/28/93 11:04 2 ;;3.5;FEE BASIS;**103**;JAN 30, 1995;Build 19 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 END K DA,DR,F,FBAASKV,FBAADDYS,FBAALT,FBAAP79,FBAATT,FBANEW,FBAOLD,FBCOUNTY,FBDX,FBI,FBRR,FBSITE,FBTYPE,FBXX,I,J,K,PI,S,T,Z,ZZ,FBPROG,PRC,PRCS,PRCSCPAN,DFN,CNT,X1,X2,FBMM 6 K DIC,DIE,FB7078,FBAA78,FBAADA,FBAAASKV,FBBEGDT,FBCD,FBDAYS,FBDEFP,FBDEV,FBENDDT,FBERR,FBNAME,FBNUM,FBO,FBOBN,FBPAYDT,FBPAYEDT,FBPOSDT,FBPSADF,FBSEQ,FBSSN,FBT,FBVEN,FBVCAR,FTP,IFN,PGM,VAL,VAR,X,Y 7 K FB("SITE"),FBAAADA,FBABD,FBDD,FBEDT,FBEND,FBFLAG,FBLG,FBMULT,FBONE,FBOUT,FBPOP,FBRIFN,FBTDT,FBTOT,FBTRDYS,FBTWO,FBZZ,FB,FBRIFN,FBRATE,FBC,FBID,FBAAOUT,FBVIEN,FBX,FBATODT,FBCNUM,FBFR 8 K FBRP 9 Q 10 ; 11 NOGOOD ;ERROR 12 W !!,"No valid Obligation Number selected" G END 13 ; 14 PROB ;ERROR 15 W !!,"Unable to get Obligation Sequence number from IFCAP!",!,"Check with IFCAP package coordinator!" Q 16 ; 17 PROB2 ;ERROR 18 W !!,"Unable to add an entry in the VA Form 7078 file. Please see Computer Staff!" Q 19 Q 1 FBNHEAU1 ;AISC/dmk - continue FBNHEAUT cnh authorization ;4/28/93 11:04 2 ;;3.5;FEE BASIS;;JAN 30, 1995 3 ;;Per VHA Directive 10-93-142, this routine should not be modified. 4 ; 5 END K DA,DR,F,FBAASKV,FBAADDYS,FBAALT,FBAAP79,FBAATT,FBANEW,FBAOLD,FBCOUNTY,FBDX,FBI,FBRR,FBSITE,FBTYPE,FBXX,I,J,K,PI,S,T,Z,ZZ,FBPROG,PRC,PRCS,PRCSCPAN,DFN,CNT,X1,X2,FBMM 6 K DIC,DIE,FB7078,FBAA78,FBAADA,FBAAASKV,FBBEGDT,FBCD,FBDAYS,FBDEFP,FBDEV,FBENDDT,FBERR,FBNAME,FBNUM,FBO,FBOBN,FBPAYDT,FBPAYEDT,FBPOSDT,FBPSADF,FBSEQ,FBSSN,FBT,FBVEN,FBVCAR,FTP,IFN,PGM,VAL,VAR,X,Y 7 K FB("SITE"),FBAAADA,FBABD,FBDD,FBEDT,FBEND,FBFLAG,FBLG,FBMULT,FBONE,FBOUT,FBPOP,FBRIFN,FBTDT,FBTOT,FBTRDYS,FBTWO,FBZZ,FB,FBRIFN,FBRATE,FBC,FBID,FBAAOUT,FBVIEN,FBX,FBATODT,FBCNUM,FBFR 8 Q 9 ; 10 NOGOOD ;ERROR 11 W !!,"No valid Obligation Number selected" G END 12 ; 13 PROB ;ERROR 14 W !!,"Unable to get Obligation Sequence number from IFCAP!",!,"Check with IFCAP package coordinator!" Q 15 ; 16 PROB2 ;ERROR 17 W !!,"Unable to add an entry in the VA Form 7078 file. Please see Computer Staff!" Q 18 Q -
WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBNHEAUT.m
r613 r623 1 FBNHEAUT ;AISC/DMK,GRR-ENTER/EDIT AUTHORIZATION ;08/07/02 2 ;;3.5;FEE BASIS;**43,103**;JAN 30, 1995;Build 19 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 D SITEP^FBAAUTL Q:FBPOP S FBAADDYS=+$P(FBSITE(0),"^",13),FBAAASKV=$P(FBSITE(1),"^"),FBPROG=$S($P(FBSITE(1),"^",6)="":"I 1",1:"I $P(^(0),U,3)=7") W !! 5 ; 6 S PRCS("TYPE")="FB",PRCS("A")="Select Obligation Number: " K PRCS("X") D EN1^PRCS58 G:Y<0 NOGOOD^FBNHEAU1 S FBOBN=$P(Y,"^",2) K PRCS("A") 7 ; 8 W !! S DIC="^DPT(",DIC(0)="QEAZM" D ^DIC G END:Y<0 S DFN=+Y 9 I $P($G(^DPT(DFN,.361)),"^")="" W !!,"ELIGIBILITY HAS NOT BEEN DETERMINED NOR PENDING, CANNOT ENTER AN AUTHORIZATION." G FBNHEAUT 10 I $P($G(^DPT(DFN,.32)),"^",4)=2 W !!,"VETERAN HAS A DISHONORABLE DISCHARGE, " S X=$P($G(^(.321)),"^") W $S(X="Y":"ONLY ELIGIBLE FOR AGENT ORANGE.",1:"NOT ELIGIBLE FOR BENEFITS.") 11 I "N"[$E(X) W ! S DIR("A")="Do you want to continue",DIR(0)="Y",DIR("B")="No" D ^DIR K DIR G FBNHEAUT:$S($D(DIRUT):1,'Y:1,1:0) 12 S DA=DFN I '$D(^FBAAA(DFN,0)) K DD,DO S (X,DINUM)=DFN,DIC="^FBAAA(",DIC(0)="LM",DLAYGO=161 D FILE^DICN K DIC,DLAYGO G:Y<0 END 13 S:'$D(^FBAAA(DFN,1,0)) ^(0)="^161.01D^^" 14 D ^FBAADEM ;G FBNHEAUT:FBAAOUT 15 ; 16 GETVEN S FBPROG=7 D DATES^FBAAUTL2 G:FBBEGDT="" FBNHEAUT 17 D GETVEN^FBAAUTL1 G END:X="^"!(X=""),GETVEN:IFN="" S FBVEN=IFN,FBPAYDT=FBBEGDT,X=+FBBEGDT D DAYS^FBAAUTL1 S FBDAYS=$S(X>(FBENDDT-FBBEGDT):(FBENDDT-FBBEGDT),1:X) 18 D GETRAT^FBNHEAU2 G:FBERR GETVEN 19 ;CREATE AN ENTRY IN FILE 161 20 K DD,DO S DLAYGO=161,DA(1)=DFN,(DIE,DIC)="^FBAAA("_DA(1)_",1,",DIC(0)="LQ",X=FBBEGDT D FILE^DICN K DLAYGO S DA=+Y,FBAAADA=DA 21 S DIE=DIC,FBPSADF=$S($D(FBSITE(1)):$P(^DIC(4,$P(FBSITE(1),"^",3),0),"^",1),1:"") 22 ; fb*3.5*103 added REFERRING PROVIDER field (161.01,104) to DR string 23 S DR=".02////^S X=FBENDDT;.03////^S X=7;S FBTYPE=7;100////^S X=DUZ;1////^S X=""YES"";.04////^S X=FBVEN;.095////1;101T;104;.065;.07;.021;.097;.08;S:X="""" Y="""";.085;S:X="""" Y="""";.086" D ^DIE 24 I $D(DTOUT)!('$D(Y)=0) S DIC="^FBAAA("_DFN_",1," G DEL 25 ; fb*3.5*103 assignment of REFERRING PROVIDER (161.01,104) for recording at 162.4,15 via the FBNH ENTER 7078 input template 26 S FBRP=$$GET1^DIQ(161.01,FBAAADA_","_DFN,104,"I") 27 S FBVEN=FBVEN_";FBAAV(" 28 ; 29 S X=FBPAYDT D DAYS^FBAAUTL1 S FBATODT=$S($E(FBPAYDT,1,5)_"00"+X>FBENDDT:FBENDDT-1,1:$E(FBPAYDT,1,5)_"00"+X) 30 D EST^FBNHEAU2 31 I $G(FBDEFP)'>0 W !,*7,"Unable to determine estimated dollar amount, based on authorization",!,"dates and current vendor contracts.",! S DA=FBAAADA,DA(1)=DFN,DIC="^FBAAA("_DFN_",1," G DEL 32 ;CHECK 1358 and get next point number. create entry in 162.4 33 S X=FBOBN K PRCS("A") S PRCS("TYPE")="FB" D EN1^PRCSUT31 I Y<0 S DIC="^FBAAA("_DFN_",1," D PROB^FBNHEAU1 G DEL 34 S FB7078=$P(FBOBN,"-",2)_"."_Y,FBSEQ=Y,DIC="^FB7078(",DIC(0)="LQ",DLAYGO=162.4,X=""""_FB7078_"""" D ^DIC K DLAYGO I Y<0 S DIC="^FBAAA("_DFN_",1," D PROB2^FBNHEAU1 G DEL 35 S (DA,FBAA78)=+Y 36 S DIE=DIC,DR="[FBNH ENTER 7078]" D ^DIE 37 I $O(^FBAAA(DFN,1,FBAAADA,2,0))>0 S ^FB7078(FBAA78,1,0)=^FBAAA(DFN,1,FBAAADA,2,0) F Z=0:0 S Z=$O(^FBAAA(DFN,1,FBAAADA,2,Z)) Q:Z'>0 S ^FB7078(FBAA78,1,Z,0)=^FBAAA(DFN,1,FBAAADA,2,Z,0) 38 S $P(^FBAAA(DFN,1,FBAAADA,0),"^",9)=FBAA78_";FB7078(",^FBAAA("AG",FBAA78_";FB7078(",DFN,FBAAADA)="" 39 ;call to create entries in file 161.23, time sensitive file 40 ;that will store patient rates 41 S FBERR=0 D FILE^FBNHEAU2 I FBERR W !,"Unable to create entry in Authorization Rate file (161.23). Contact IRM.",! G ADM 42 ;call to create entry in ifcap 424. 43 S FBMM=$E(FBBEGDT,4,5) 44 S PRCS("TYPE")="FB" K PRCS("A") S FBNAME=$$NAME^FBCHREQ2(DFN),FBSSN=$$SSN^FBAAUTL(DFN) D NOW^%DTC S FBPOSDT=%,X=FBOBN_"^"_FBPOSDT_"^"_FBDEFP_"^^"_FBSEQ_"^"_FBNAME_" ("_FBSSN_")"_"^"_DFN_";"_FBAA78_";"_$P(FBOBN,"-",2)_";"_FBMM D EN2^PRCS58 45 I +Y=0 W !!,"Error trying to Post to 1358, DID NOT POST. Error was:",!,Y,!?7,"Adjust the 1358 for $",$FN(FBDEFP,",",2)," then use the",!?7,"Post Commitments for Obligation option!",!,*7 G ADM 46 W !!,$J(FBDEFP,7,2)," Posted to 1358" 47 ; 48 ; 49 CHEKP78 S FBNUM=$P(FBSITE(1),"^",5),FBO=$P(FBSITE(1),"^",7),FBT=$P(FBSITE(1),"^",8) D FBO^FBCHP78 G END:$D(DIRUT) S IOP="Q",FB7078=FBAA78 W ! 50 D IFCAP^FBAAUTL2 51 I '$D(FBERR(1)) S VAR="FB7078^FBNUM^FBO^FBT^FB(""SITE"")",VAL=FB7078_"^"_FBNUM_"^"_FBO_"^"_FBT_"^"_FB("SITE"),PGM="START^FBCHP78",%ZIS("B")="" W ! D ZIS^FBAAUTL 52 ; 53 ADM S DIR(0)="Y",DIR("A")="Do you want to Admit Patient to CNH now",DIR("B")="YES" D ^DIR K DIR I Y S FBVEN=+FBVEN,FTP=FBAAADA,FBAABDT=FBBEGDT,FBAAEDT=FBENDDT,FBEND=1,FBRCHK=1 D RD2^FBNHEA 54 ; 55 END D END^FBNHEAU1 56 Q 57 ; 58 DEL S DIK=DIC D ^DIK K DIK,DIC D END^FBNHEAU1 G FBNHEAUT 1 FBNHEAUT ;AISC/DMK,GRR-ENTER/EDIT AUTHORIZATION ;08/07/02 2 ;;3.5;FEE BASIS;**43**;JAN 30, 1995 3 ;;Per VHA Directive 10-93-142, this routine should not be modified. 4 D SITEP^FBAAUTL Q:FBPOP S FBAADDYS=+$P(FBSITE(0),"^",13),FBAAASKV=$P(FBSITE(1),"^"),FBPROG=$S($P(FBSITE(1),"^",6)="":"I 1",1:"I $P(^(0),U,3)=7") W !! 5 ; 6 S PRCS("TYPE")="FB",PRCS("A")="Select Obligation Number: " K PRCS("X") D EN1^PRCS58 G:Y<0 NOGOOD^FBNHEAU1 S FBOBN=$P(Y,"^",2) K PRCS("A") 7 ; 8 W !! S DIC="^DPT(",DIC(0)="QEAZM" D ^DIC G END:Y<0 S DFN=+Y 9 I $P($G(^DPT(DFN,.361)),"^")="" W !!,"ELIGIBILITY HAS NOT BEEN DETERMINED NOR PENDING, CANNOT ENTER AN AUTHORIZATION." G FBNHEAUT 10 I $P($G(^DPT(DFN,.32)),"^",4)=2 W !!,"VETERAN HAS A DISHONORABLE DISCHARGE, " S X=$P($G(^(.321)),"^") W $S(X="Y":"ONLY ELIGIBLE FOR AGENT ORANGE.",1:"NOT ELIGIBLE FOR BENEFITS.") 11 I "N"[$E(X) W ! S DIR("A")="Do you want to continue",DIR(0)="Y",DIR("B")="No" D ^DIR K DIR G FBNHEAUT:$S($D(DIRUT):1,'Y:1,1:0) 12 S DA=DFN I '$D(^FBAAA(DFN,0)) K DD,DO S (X,DINUM)=DFN,DIC="^FBAAA(",DIC(0)="LM",DLAYGO=161 D FILE^DICN K DIC,DLAYGO G:Y<0 END 13 S:'$D(^FBAAA(DFN,1,0)) ^(0)="^161.01D^^" 14 D ^FBAADEM ;G FBNHEAUT:FBAAOUT 15 ; 16 GETVEN S FBPROG=7 D DATES^FBAAUTL2 G:FBBEGDT="" FBNHEAUT 17 D GETVEN^FBAAUTL1 G END:X="^"!(X=""),GETVEN:IFN="" S FBVEN=IFN,FBPAYDT=FBBEGDT,X=+FBBEGDT D DAYS^FBAAUTL1 S FBDAYS=$S(X>(FBENDDT-FBBEGDT):(FBENDDT-FBBEGDT),1:X) 18 D GETRAT^FBNHEAU2 G:FBERR GETVEN 19 ;CREATE AN ENTRY IN FILE 161 20 K DD,DO S DLAYGO=161,DA(1)=DFN,(DIE,DIC)="^FBAAA("_DA(1)_",1,",DIC(0)="LQ",X=FBBEGDT D FILE^DICN K DLAYGO S DA=+Y,FBAAADA=DA 21 S DIE=DIC,FBPSADF=$S($D(FBSITE(1)):$P(^DIC(4,$P(FBSITE(1),"^",3),0),"^",1),1:"") 22 S DR=".02////^S X=FBENDDT;.03////^S X=7;S FBTYPE=7;100////^S X=DUZ;1////^S X=""YES"";.04////^S X=FBVEN;.095////1;101T;.065;.07;.021;.097;.08;S:X="""" Y="""";.085;S:X="""" Y="""";.086" D ^DIE 23 I $D(DTOUT)!('$D(Y)=0) S DIC="^FBAAA("_DFN_",1," G DEL 24 S FBVEN=FBVEN_";FBAAV(" 25 ; 26 S X=FBPAYDT D DAYS^FBAAUTL1 S FBATODT=$S($E(FBPAYDT,1,5)_"00"+X>FBENDDT:FBENDDT-1,1:$E(FBPAYDT,1,5)_"00"+X) 27 D EST^FBNHEAU2 28 I $G(FBDEFP)'>0 W !,*7,"Unable to determine estimated dollar amount, based on authorization",!,"dates and current vendor contracts.",! S DA=FBAAADA,DA(1)=DFN,DIC="^FBAAA("_DFN_",1," G DEL 29 ;CHECK 1358 and get next point number. create entry in 162.4 30 S X=FBOBN K PRCS("A") S PRCS("TYPE")="FB" D EN1^PRCSUT31 I Y<0 S DIC="^FBAAA("_DFN_",1," D PROB^FBNHEAU1 G DEL 31 S FB7078=$P(FBOBN,"-",2)_"."_Y,FBSEQ=Y,DIC="^FB7078(",DIC(0)="LQ",DLAYGO=162.4,X=""""_FB7078_"""" D ^DIC K DLAYGO I Y<0 S DIC="^FBAAA("_DFN_",1," D PROB2^FBNHEAU1 G DEL 32 S (DA,FBAA78)=+Y 33 S DIE=DIC,DR="[FBNH ENTER 7078]" D ^DIE 34 I $O(^FBAAA(DFN,1,FBAAADA,2,0))>0 S ^FB7078(FBAA78,1,0)=^FBAAA(DFN,1,FBAAADA,2,0) F Z=0:0 S Z=$O(^FBAAA(DFN,1,FBAAADA,2,Z)) Q:Z'>0 S ^FB7078(FBAA78,1,Z,0)=^FBAAA(DFN,1,FBAAADA,2,Z,0) 35 S $P(^FBAAA(DFN,1,FBAAADA,0),"^",9)=FBAA78_";FB7078(",^FBAAA("AG",FBAA78_";FB7078(",DFN,FBAAADA)="" 36 ;call to create entries in file 161.23, time sensitive file 37 ;that will store patient rates 38 S FBERR=0 D FILE^FBNHEAU2 I FBERR W !,"Unable to create entry in Authorization Rate file (161.23). Contact IRM.",! G ADM 39 ;call to create entry in ifcap 424. 40 S FBMM=$E(FBBEGDT,4,5) 41 S PRCS("TYPE")="FB" K PRCS("A") S FBNAME=$$NAME^FBCHREQ2(DFN),FBSSN=$$SSN^FBAAUTL(DFN) D NOW^%DTC S FBPOSDT=%,X=FBOBN_"^"_FBPOSDT_"^"_FBDEFP_"^^"_FBSEQ_"^"_FBNAME_" ("_FBSSN_")"_"^"_DFN_";"_FBAA78_";"_$P(FBOBN,"-",2)_";"_FBMM D EN2^PRCS58 42 I +Y=0 W !!,"Error trying to Post to 1358, DID NOT POST. Error was:",!,Y,!?7,"Adjust the 1358 for $",$FN(FBDEFP,",",2)," then use the",!?7,"Post Commitments for Obligation option!",!,*7 G ADM 43 W !!,$J(FBDEFP,7,2)," Posted to 1358" 44 ; 45 ; 46 CHEKP78 S FBNUM=$P(FBSITE(1),"^",5),FBO=$P(FBSITE(1),"^",7),FBT=$P(FBSITE(1),"^",8) D FBO^FBCHP78 G END:$D(DIRUT) S IOP="Q",FB7078=FBAA78 W ! 47 D IFCAP^FBAAUTL2 48 I '$D(FBERR(1)) S VAR="FB7078^FBNUM^FBO^FBT^FB(""SITE"")",VAL=FB7078_"^"_FBNUM_"^"_FBO_"^"_FBT_"^"_FB("SITE"),PGM="START^FBCHP78",%ZIS("B")="" W ! D ZIS^FBAAUTL 49 ; 50 ADM S DIR(0)="Y",DIR("A")="Do you want to Admit Patient to CNH now",DIR("B")="YES" D ^DIR K DIR I Y S FBVEN=+FBVEN,FTP=FBAAADA,FBAABDT=FBBEGDT,FBAAEDT=FBENDDT,FBEND=1,FBRCHK=1 D RD2^FBNHEA 51 ; 52 END D END^FBNHEAU1 53 Q 54 ; 55 DEL S DIK=DIC D ^DIK K DIK,DIC D END^FBNHEAU1 G FBNHEAUT -
WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBNHEDAT.m
r613 r623 1 FBNHEDAT ;AISC/GRR-ENTER/EDIT AUTHORIZATION ;02:07 PM 11 Apr 1990; 2 ;;3.5;FEE BASIS;**103**;JAN 30, 1995;Build 19 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 D SITEP^FBAAUTL 5 RD1 S U="^" D GETVET^FBAAUTL1 G:DFN="" END 6 S FBPROG="I $P(^(0),U,3)=7" D GETAUTH^FBAAUTL1 G RD1:'CNT!(FTP']"")!($D(DIRUT)) S (FBOLD,FBNEW,FBERR)="" 7 K FBAUT,CNT S (DA(1),D0)=DFN,FBOLD=^FBAAA(DFN,1,FTP,0),DA=FTP,FBAAADA=DA,DIE="^FBAAA("_DFN_",1,",FBO=$P(FBOLD,"^"),(FB1,FBAA(2))=$P(FBOLD,"^",2) 8 S FBPROG=7 D DATES^FBAAUTL2 S FBAA(1)=$S($G(FBBEGDT):FBBEGDT,1:FBO),FBAA(2)=$S($G(FBENDDT):FBENDDT,1:FB1) 9 DR S DR=".01////^S X=FBAA(1);.02////^S X=FBAA(2)" 10 ; fb*3.5*103 add REFERRING PROVIDER (161.01,104) to DR string 11 S DR(1,161.01,1)="@2;.065;.07;.021;.08;S:X="""" Y=101;.085;S:X="""" Y=101;.086;101;104;.097" D ^DIE 12 S FBNEW=$S('$D(DA):"",'$D(^FBAAA(DFN,1,DA,0)):"",1:^(0)) K DR 13 I $D(Y)>0,FBNEW=""!(FBNEW=FBOLD) G RD1 14 I FBNEW'=FBOLD,$P(FBNEW,"^")>$P(FBNEW,"^",2) S DR=".01////^S X=FBO;.02////^S X=FB1" D ^DIE K DR D ER G DR 15 ; 16 S FBAA78=FB7078 D ^FBNHEDA1 K FBAA78 I FBERR S DA(1)=DFN,DA=FTP,DIE="^FBAAA("_DA(1)_",1,",DR=".01////^S X=FBO;.02////^S X=FB1" D ^DIE G END 17 ; fb*3.5*103 add the REFERRING PROVIDER (162.4,15) to the DR string; stuff with the value stored at 161.01,104 18 S DIE="^FB7078(",DA=FB7078,FBAA78=DA,DR="5;6;15////^S X=$$GET1^DIQ(161.01,FBAAADA_"",""_DFN,104,""I"")" I 'DA W !!,*7,"No 7078 on file!",! G END 19 D:FBOLD'=FBNEW CHANGED 20 GO D ^DIE 21 I $O(^FBAAA(DFN,1,FBAAADA,2,0))>0 K ^FB7078(FBAA78,1) S ^FB7078(FBAA78,1,0)=^FBAAA(DFN,1,FBAAADA,2,0) F Z=0:0 S Z=$O(^FBAAA(DFN,1,FBAAADA,2,Z)) Q:Z'>0 S ^FB7078(FBAA78,1,Z,0)=^FBAAA(DFN,1,FBAAADA,2,Z,0) 22 RD2 S DIR(0)="Y",DIR("A")="Want to Queue 7078 for printing",DIR("B")=$S(FBOLD=FBNEW:"No",1:"Yes") D ^DIR K DIR G:Y'>0 RD1 23 CHEKP78 S FBNUM=$P(FBSITE(1),"^",5),FBO=$P(FBSITE(1),"^",7),FBT=$P(FBSITE(1),"^",8) D FBO^FBCHP78 G END:$D(DIRUT) S IOP="Q",%ZIS("B")="",FB7078=FBAA78,FB("SITE")=$P(FBSITE(1),"^",3) W ! 24 S VAR="FB7078^FBNUM^FBO^FBT^FB(""SITE"")",VAL=FB7078_"^"_FBNUM_"^"_FBO_"^"_FBT_"^"_FB("SITE"),PGM="START^FBCHP78" W ! D ZIS^FBAAUTL 25 ; 26 END K D0,DA,FBAASKV,FBAADDYS,FBAALT,FBAAP79,FBAATT,FBNUM,FBDEV,FBO,FBT,FB7078,FBAA78,FBCOUNTY,FBDX,FBI,FBRR,FBVEN,FBTYPE,FBXX,I,J,K,PI,FBOLD,FBNEW,FBPSADF,FBAADA,FB1,FBERR,FBOUT,FBIFN,FBZ,FBBEGDT,FBENDDT,FBAUT 27 K DIE,DIR,FBAAADA,FTP,PGM,VAL,VAR,X,Y,Z,DIC,A,FBAABDT,FBAAEDT,FBAAOUT,FBASSOC,FBLOC,FBPOV,FBPROG,FBPSA,FBPT,FBSITE,FBTT,PTYPE,T,ZZ,FB("SITE"),FBPOP,FBAA,FBBDT,FBTDAYS,HOLDX 28 D END^FBNHEAU1 29 D CLOSE^FBAAUTL 30 Q 31 ; 32 CHANGED S:$P(FBOLD,"^",1)'=$P(FBNEW,"^",1) DR="3////^S X=$P(FBNEW,U,1);"_DR 33 S:$P(FBOLD,"^",2)'=$P(FBNEW,"^",2) DR="4////^S X=$P(FBNEW,U,2);"_DR 34 Q 35 ; 36 ER W !,*7,"From Date cannot be greater than the To Date.",! 37 Q 38 ; 39 ER1 W !,*7,"This patient has movements after the authorization to date. You must",!,"edit the patient's movements first.",! 40 Q 1 FBNHEDAT ;AISC/GRR-ENTER/EDIT AUTHORIZATION ;02:07 PM 11 Apr 1990; 2 ;;3.5;FEE BASIS;;JAN 30, 1995 3 ;;Per VHA Directive 10-93-142, this routine should not be modified. 4 D SITEP^FBAAUTL 5 RD1 S U="^" D GETVET^FBAAUTL1 G:DFN="" END 6 S FBPROG="I $P(^(0),U,3)=7" D GETAUTH^FBAAUTL1 G RD1:'CNT!(FTP']"")!($D(DIRUT)) S (FBOLD,FBNEW,FBERR)="" 7 K FBAUT,CNT S (DA(1),D0)=DFN,FBOLD=^FBAAA(DFN,1,FTP,0),DA=FTP,FBAAADA=DA,DIE="^FBAAA("_DFN_",1,",FBO=$P(FBOLD,"^"),(FB1,FBAA(2))=$P(FBOLD,"^",2) 8 S FBPROG=7 D DATES^FBAAUTL2 S FBAA(1)=$S($G(FBBEGDT):FBBEGDT,1:FBO),FBAA(2)=$S($G(FBENDDT):FBENDDT,1:FB1) 9 DR S DR=".01////^S X=FBAA(1);.02////^S X=FBAA(2)" 10 S DR(1,161.01,1)="@2;.065;.07;.021;.08;S:X="""" Y=101;.085;S:X="""" Y=101;.086;101;.097" D ^DIE 11 S FBNEW=$S('$D(DA):"",'$D(^FBAAA(DFN,1,DA,0)):"",1:^(0)) K DR 12 I $D(Y)>0,FBNEW=""!(FBNEW=FBOLD) G RD1 13 I FBNEW'=FBOLD,$P(FBNEW,"^")>$P(FBNEW,"^",2) S DR=".01////^S X=FBO;.02////^S X=FB1" D ^DIE K DR D ER G DR 14 ; 15 S FBAA78=FB7078 D ^FBNHEDA1 K FBAA78 I FBERR S DA(1)=DFN,DA=FTP,DIE="^FBAAA("_DA(1)_",1,",DR=".01////^S X=FBO;.02////^S X=FB1" D ^DIE G END 16 ; 17 S DIE="^FB7078(",DA=FB7078,FBAA78=DA,DR="5;6" I 'DA W !!,*7,"No 7078 on file!",! G END 18 D:FBOLD'=FBNEW CHANGED 19 GO D ^DIE 20 I $O(^FBAAA(DFN,1,FBAAADA,2,0))>0 K ^FB7078(FBAA78,1) S ^FB7078(FBAA78,1,0)=^FBAAA(DFN,1,FBAAADA,2,0) F Z=0:0 S Z=$O(^FBAAA(DFN,1,FBAAADA,2,Z)) Q:Z'>0 S ^FB7078(FBAA78,1,Z,0)=^FBAAA(DFN,1,FBAAADA,2,Z,0) 21 RD2 S DIR(0)="Y",DIR("A")="Want to Queue 7078 for printing",DIR("B")=$S(FBOLD=FBNEW:"No",1:"Yes") D ^DIR K DIR G:Y'>0 RD1 22 CHEKP78 S FBNUM=$P(FBSITE(1),"^",5),FBO=$P(FBSITE(1),"^",7),FBT=$P(FBSITE(1),"^",8) D FBO^FBCHP78 G END:$D(DIRUT) S IOP="Q",%ZIS("B")="",FB7078=FBAA78,FB("SITE")=$P(FBSITE(1),"^",3) W ! 23 S VAR="FB7078^FBNUM^FBO^FBT^FB(""SITE"")",VAL=FB7078_"^"_FBNUM_"^"_FBO_"^"_FBT_"^"_FB("SITE"),PGM="START^FBCHP78" W ! D ZIS^FBAAUTL 24 ; 25 END K D0,DA,FBAASKV,FBAADDYS,FBAALT,FBAAP79,FBAATT,FBNUM,FBDEV,FBO,FBT,FB7078,FBAA78,FBCOUNTY,FBDX,FBI,FBRR,FBVEN,FBTYPE,FBXX,I,J,K,PI,FBOLD,FBNEW,FBPSADF,FBAADA,FB1,FBERR,FBOUT,FBIFN,FBZ,FBBEGDT,FBENDDT,FBAUT 26 K DIE,DIR,FBAAADA,FTP,PGM,VAL,VAR,X,Y,Z,DIC,A,FBAABDT,FBAAEDT,FBAAOUT,FBASSOC,FBLOC,FBPOV,FBPROG,FBPSA,FBPT,FBSITE,FBTT,PTYPE,T,ZZ,FB("SITE"),FBPOP,FBAA,FBBDT,FBTDAYS,HOLDX 27 D END^FBNHEAU1 28 D CLOSE^FBAAUTL 29 Q 30 ; 31 CHANGED S:$P(FBOLD,"^",1)'=$P(FBNEW,"^",1) DR="3////^S X=$P(FBNEW,U,1);"_DR 32 S:$P(FBOLD,"^",2)'=$P(FBNEW,"^",2) DR="4////^S X=$P(FBNEW,U,2);"_DR 33 Q 34 ; 35 ER W !,*7,"From Date cannot be greater than the To Date.",! 36 Q 37 ; 38 ER1 W !,*7,"This patient has movements after the authorization to date. You must",!,"edit the patient's movements first.",! 39 Q -
WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBPCR.m
r613 r623 1 FBPCR ;AISC/DMK,GRR,TET-POTENTIAL COST RECOVERY OUTPUT DRIVER ;23 May 2006 10:06 AM 2 ;;3.5;FEE BASIS;**12,48,76,98,103**;JAN 30, 1995;Build 19 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 ; DBIA SUPPORTED REF $$NPI^XUSNPI = 4532 5 DOC ;Refer to fbdoc, tag fbpcr, for documentation of fbpcr* routines 6 PSF ;select one/many/all primary service failities 7 S FBARRLTC="" 8 W !! S DIC="^DIC(4,",VAUTSTR="Primary Service Facility",VAUTNI=2,VAUTVB="FBPSV" D FIRST^VAUTOMA K DIC I Y=-1 G EXIT 9 ARRAY ;set fee program array for all programs 10 S FBPI=0 F S FBPI=$O(^FBAA(161.8,FBPI)) Q:'FBPI S FBPIN=$G(^(FBPI,0)) I $P(FBPIN,U,3) S FBPROG(FBPI)=$P(FBPIN,U) 11 I '$D(FBPROG) G EXIT 12 ;prepare array with LTC POV codes 13 D MKARRLTC^FBPCR4 14 ;what party to include 15 K DIR 16 S DIR(0)="SO^P:Patient;I:Insurance;B:Both",DIR("A")="Include (P)atient Co-pays / (I)nsurance / (B)oth",DIR("B")="Both" 17 S DIR("?")=" Select type of recover to include",DIR("?",1)=" P - include only recover from patient copays",DIR("?",2)=" I - include only recover from insurance",DIR("?",3)=" B - include both",DIR("L")="" 18 D ^DIR S FBPARTY=$S($G(Y(0))="Patient":1,$G(Y(0))="Insurance":2,$G(Y(0))="Both":3,X="Both":3,1:0) 19 K DIR 20 G:FBPARTY=0 EXIT 21 ;what type of copay to include 22 S FBCOPAY=3 23 I FBPARTY'=2 D 24 . S DIR(0)="SO^M:MeansTest;L:LTC;B:Both",DIR("A")="Include (M)eans Test Co-pays /(L)TC Co-pays /(B)oth",DIR("B")="Both" 25 . S DIR("?")=" Select services to include",DIR("?",1)=" M - include only Means Test copays",DIR("?",2)=" L - include only LTC copays",DIR("?",3)=" B - include both",DIR("L")="" 26 . D ^DIR S FBCOPAY=$S($G(Y(0))="LTC":1,$G(Y(0))="MeansTest":2,$G(Y(0))="Both":3,X="Both":3,1:0) 27 . K DIR 28 G:FBCOPAY=0 EXIT 29 ; 30 ;include patients if their insurance informations is unavailable? 31 S FBINCUNK=0 32 I FBPARTY=2!(FBPARTY=3) D 33 . S FBINCUNK=1 34 . N Y,X 35 . W !! 36 . S DIR("A")="Do you want to include patients whose insurance status is unavailable? " 37 . S DIR("?")="Please answer Yes or No." 38 . S DIR("B")="YES",DIR(0)="YA^^" 39 . D ^DIR K DIR 40 . I $G(DIRUT) S FBINCUNK=-1 Q 41 . I $G(Y)=0 S FBINCUNK=0 42 I FBINCUNK=-1 G EXIT ;uparrow - exit 43 ; 44 DATE ;select date range 45 D DATE^FBAAUTL I FBPOP G PSF 46 S FBBDATE=BEGDATE,FBEDATE=ENDDATE 47 S Z=9999999.9999,FBBEG=Z-FBEDATE,FBEND=Z-FBBDATE 48 Q K ^TMP($J,"FB"),^TMP($J,"FBINSIBAPI"),DIC 49 ; 50 S VAR="FBINCUNK^FBARRLTC^FBARRLTC(^FBPARTY^FBCOPAY^FBNAME^FBIEN^FBID^FBBEG^FBEND^FBBDATE^FBEDATE^FBPSV^FBPSV(^FBPROG(",VAL=VAR,PGM="DQ^FBPCR",IOP="Q" D ZIS^FBAAUTL G:FBPOP EXIT 51 DQ S $P(FBDASH,"=",80)="",$P(FBDASH1,"-",80)="",FBPG=0,FBCRT=$S($E(IOST,1,2)="C-":1,1:0),FBOUT=0,FBBEG=FBBEG-.9 U IO 52 SORT ;sort driver for payment output(s) 53 S FBPI=0 F S FBPI=$O(FBPROG(FBPI)) Q:'FBPI S FBXPROG=FBPROG(FBPI) D 54 .I FBPI=2 D EN^FBPCR2 ;outpatient payments 55 .I FBPI=3 D EN^FBPCR3 ;pharmacy payments 56 .I FBPI=6!(FBPI=7) S:FBPI=6&($D(FBPROG(7))) FBPI=67 D EN^FBPCR67 S:FBPI=67 FBPI=7 ;civil hospital/cnh payments 57 PRINT ;print driver for payment output(s) 58 I $G(^TMP($J,"FBINSIBAPI"))>0 D HDRUNK 59 S FBPI=$O(^TMP($J,"FB",0)) I FBPI']"" D WMSG G OUT 60 S FBSTA=0 61 S FBPSF=0 F S FBPSF=$O(^TMP($J,"FB",FBPSF)) Q:'FBPSF!FBOUT D STA S FBPT="" F S FBPT=$O(^TMP($J,"FB",FBPSF,FBPT)) Q:FBPT']""!FBOUT S DFN=$P(FBPT,";",2) D VET S FBPI=0 F S FBPI=$O(FBPROG(FBPI)) Q:'FBPI S FBXPROG=FBPROG(FBPI) D Q:FBOUT 62 .I FBPSF_FBPT'=FBSTA D HDR Q:FBOUT 63 .I FBPI=2,$D(^TMP($J,"FB",FBPSF,FBPT,FBPI)) D PRINT^FBPCR2 Q 64 .I FBPI=3 D:$D(^TMP($J,"FB",FBPSF,FBPT,FBPI)) PRINT^FBPCR3 Q 65 .I FBPI=6!(FBPI=7) D:$D(^TMP($J,"FB",FBPSF,FBPT,FBPI)) PRINT^FBPCR671 Q 66 OUT I $G(^TMP($J,"FBINSIBAPI"))>0 D ERRHDL^FBPCR4 67 I FBOUT!$D(ZTQUEUED) G EXIT 68 D EXIT G PSF 69 Q 70 EXIT ;kill and quit 71 KILL ;kill all variables set in the FBPCR* routines, other than fbx 72 D CLOSE^FBAAUTL K ^TMP($J,"FB") 73 K A1,A2,A3,BEGDATE,C,D,D2,DFN,DIC,DIR,DTOUT,DUOUT,ENDDATE,FBPDXC,FBPARTY,FBCOPAY,FBARRLTC,FBINCUNK 74 K FBAAA,FBAACPTC,FBAC,FBAP,FBBATCH,FBBDATE,FBBEG,FBBN,FBCATC,FBCNT,FBCP,FBCRT,FBDA1,FBDASH,FBDASH1,FBDATA,FBDOB,FBDRUG,FBDT,FBDT1,FBDOS,FBDX,FBDX1,FBEDATE,FBEND,FBERR,FBFD,FBFD1,FBHEAD 75 K FBI,FBID,FBIEN,FBIN,FBINS,FBINVN,FBIX,FBJ,FBLOC,FBM,FBNAME,FBOB,FBOPI,FBOUT,FBOV,FBP,FBPAT,FBPD,FBPDX,FBPG,FBPI,FBPID,FBPIN,FBPNAME,FBPROC,FBPROC1,FBPROG,FBPSF,FBPSFNAM,FBPSFNUM,FBPSV,FBPT,FBPV,FBQTY,FBREIM,FBRX 76 K FBSC,FBSL,FBSTA,FBSTR,FBSUSP,FBTA,FBTYPE,FBV,FBVCHAIN,FBVEN,FBVENID,FBVNAME,FBVI,FBVID,FBVP,FBXPROG,FBY,FBZ,I,IOP,J,K,L,M,N,PGM,T,V,VA,VAERR,VAL,VAR,VAUTNI,VAUTSTR,VAUTVB,X,Y,Z,FBSTANPI,FBXX 77 Q 78 WMSG ;write message if no matches found 79 D HDR W !!?3,"There are no potential cost recoveries on file" 80 W !?5,"for specified date range: ",$$DATX^FBAAUTL(FBBDATE)," through ",$$DATX^FBAAUTL(FBEDATE) 81 I 'FBPSV D 82 .W ",",!?5,"and selected Primary Service Area(s):" 83 .S FBPSF=0 F S FBPSF=$O(FBPSV(FBPSF)) Q:'FBPSF W !?31,$G(FBPSV(FBPSF)) 84 E W !?5,"and ALL Primary Service Areas " 85 W ".",*7,!! 86 Q 87 ; 88 CATC(DFN,FBDT,FBPOV) ; 89 ;treats all copays as Means test for date < 3020705 (JULY 5,2002) 90 ;check if patient is liable for copay 91 ;INPUT: 92 ; DFN = IEN of Patient file 93 ; FBDT= Date 94 ; FBPOV = POV code (for LTC determination) 95 ;OUTPUT: 96 ;0 - the patient is not liable for any co-pay; 97 ;1 - if Means test catc or pending adjudication and agree to pay deduc 98 ;2 - the patient is liable for LTC co-pay; 99 ;3 - no 1010EC on file 100 ;4 - more analysis is needed to determine the patient liability 101 N FBLTC,FBISLTC 102 S FBCATC=$$BIL^DGMTUB(DFN,FBDT) 103 I '$D(FBPOV)!(FBDT<3020705) Q $S(FBCATC:1,1:0) 104 S FBISLTC=$$ISLTC^FBPCR4(FBPOV) 105 I FBISLTC=0 Q $S(FBCATC:1,1:0) ;Means test 106 I FBISLTC=2 Q 0 ;LTC-service, but LTC-copay is not applicable 107 S FBLTC=$$LTCST^FBPCR4(DFN,FBDT) 108 I FBLTC=2 Q 2 ;LTC copay 109 I FBLTC=0 Q 3 ;no 1010EC on file 110 I FBLTC=4 Q 4 ;more info needed 111 Q 0 ;exemption from LTC -copay 112 ; 113 VET ;set vet name/ssn/dob info 114 ;INPUT: DFN = IEN of Patient file 115 ; FBPI = IEN of fee program (optional) 116 ;OUTPUT: FBPNAME = Patient's name 117 ; FBPID = Patient's pid 118 ; FBDOB = Patient's dob (if pharmacy fee program) 119 N N 120 S N=$G(^DPT(DFN,0)),FBPNAME=$P(N,U),FBPID=$$SSN^FBAAUTL(DFN),FBDOB=$$FMTE^XLFDT($P(N,U,3)) 121 Q 122 STA ;set station name & number 123 ;INPUT = FBPSF - IEN to institution file 124 ;OUTPUT = FBPSFNAM = station name 125 ; FBPSFNUM = station number 126 S FBPSFNAM=$P($G(^DIC(4,FBPSF,0)),U),FBPSFNUM=$P($G(^DIC(4,FBPSF,99)),U) 127 S:FBPSFNAM=+FBPSFNAM FBPSFNAM="UNKNOWN" 128 S FBSTANPI=$S($G(FBPSFNAM)="":"",FBPSFNAM="UNKNOWN":"",1:$P($$NPI^XUSNPI("Organization_ID",FBPSF),U,1)) 129 Q 130 PAGE ;form feed when new station/patient 131 S FBSTA=$G(FBPSF)_$G(FBPT) 132 I FBCRT&(FBPG'=0) D CR Q:FBOUT 133 I FBPG>0!FBCRT W @IOF 134 S FBPG=FBPG+1 135 Q 136 CR ;read for display 137 S DIR(0)="E" W ! D ^DIR K DIR S:$D(DUOUT)!($D(DTOUT)) FBOUT=1 138 Q 139 HDR ;general header for potential recoveries 140 D PAGE Q:FBOUT 141 W !?(IOM-30/2),"POTENTIAL COST RECOVERY REPORT" 142 W !?(IOM-(11+$L($G(FBPSFNAM))+$L($G(FBPSFNUM)))/2),"Division: ",$G(FBPSFNUM)," ",$G(FBPSFNAM) 143 W !?(IOM-14/2),"NPI: ",$S($G(FBSTANPI)="":"",$G(FBSTANPI)<1:"",1:$G(FBSTANPI)) 144 W !?(IOM-19/2),$$DATX^FBAAUTL(FBBDATE)," - ",$$DATX^FBAAUTL(FBEDATE) 145 W !?71,"Page: ",FBPG 146 W !,"Patient: ",$G(FBPNAME),?40,"Pat. ID: ",$G(FBPID),?62,"DOB: ",$G(FBDOB) 147 W ! 148 I FBINCUNK=1,$D(^TMP($J,"FBINSIBAPI",+$G(DFN))) W ">> Warning: accurate insurance information for the patient is unavailable" 149 W !?3,"('*' Represents Reimbursement to Patient",?50,"'#' Represents Voided Payment)" 150 W !,FBDASH 151 W ! D:$D(DFN) INS^DGRPDB 152 Q 153 HDRUNK ;Warning message if patient's insurance status is unknown 154 D PAGE Q:FBOUT 155 W !?(IOM-30/2),"POTENTIAL COST RECOVERY REPORT" 156 W !?(IOM-(11+$L($G(FBPSFNAM))+$L($G(FBPSFNUM)))/2),"Division: ",$G(FBPSFNUM)," ",$G(FBPSFNAM) 157 W !?(IOM-19/2),$$DATX^FBAAUTL(FBBDATE)," - ",$$DATX^FBAAUTL(FBEDATE) 158 W !?71,"Page: ",FBPG 159 W !,"------------------------------ !!! WARNING !!! --------------------------------" 160 W !,"This report is incomplete due to problems with obtaining insurance information" 161 W !,"for those patients listed in a separate section in the end of the report. You" 162 W !,"may want to rerun the report again to get more accurate results." 163 W !,FBDASH 164 I FBINCUNK=1 D 165 . W !,"Note: You have chosen to include patients with unknown insurance status in" 166 . W !,"this report. Please be aware that these patients will be treated as if they" 167 . W !,"have billable insurance and their treatment details will be marked accordingly." 168 . W !,"The names of these patients will be accompanied with the following message" 169 . W !,"to order to identify them:" 170 . W !,">> Warning: accurate insurance information for the patient is unavailable" 171 . W !,FBDASH 172 Q 1 FBPCR ;AISC/DMK,GRR,TET-POTENTIAL COST RECOVERY OUTPUT DRIVER ;23 May 2006 10:06 AM 2 ;;3.5;FEE BASIS;**12,48,76,98**;JAN 30, 1995;Build 54 3 ;;Per VHA Directive 10-93-142, this routine should not be modified. 4 DOC ;Refer to fbdoc, tag fbpcr, for documentation of fbpcr* routines 5 PSF ;select one/many/all primary service failities 6 S FBARRLTC="" 7 W !! S DIC="^DIC(4,",VAUTSTR="Primary Service Facility",VAUTNI=2,VAUTVB="FBPSV" D FIRST^VAUTOMA K DIC I Y=-1 G EXIT 8 ARRAY ;set fee program array for all programs 9 S FBPI=0 F S FBPI=$O(^FBAA(161.8,FBPI)) Q:'FBPI S FBPIN=$G(^(FBPI,0)) I $P(FBPIN,U,3) S FBPROG(FBPI)=$P(FBPIN,U) 10 I '$D(FBPROG) G EXIT 11 ;prepare array with LTC POV codes 12 D MKARRLTC^FBPCR4 13 ;what party to include 14 K DIR 15 S DIR(0)="SO^P:Patient;I:Insurance;B:Both",DIR("A")="Include (P)atient Co-pays / (I)nsurance / (B)oth",DIR("B")="Both" 16 S DIR("?")=" Select type of recover to include",DIR("?",1)=" P - include only recover from patient copays",DIR("?",2)=" I - include only recover from insurance",DIR("?",3)=" B - include both",DIR("L")="" 17 D ^DIR S FBPARTY=$S($G(Y(0))="Patient":1,$G(Y(0))="Insurance":2,$G(Y(0))="Both":3,X="Both":3,1:0) 18 K DIR 19 G:FBPARTY=0 EXIT 20 ;what type of copay to include 21 S FBCOPAY=3 22 I FBPARTY'=2 D 23 . S DIR(0)="SO^M:MeansTest;L:LTC;B:Both",DIR("A")="Include (M)eans Test Co-pays /(L)TC Co-pays /(B)oth",DIR("B")="Both" 24 . S DIR("?")=" Select services to include",DIR("?",1)=" M - include only Means Test copays",DIR("?",2)=" L - include only LTC copays",DIR("?",3)=" B - include both",DIR("L")="" 25 . D ^DIR S FBCOPAY=$S($G(Y(0))="LTC":1,$G(Y(0))="MeansTest":2,$G(Y(0))="Both":3,X="Both":3,1:0) 26 . K DIR 27 G:FBCOPAY=0 EXIT 28 ; 29 ;include patients if their insurance informations is unavailable? 30 S FBINCUNK=0 31 I FBPARTY=2!(FBPARTY=3) D 32 . S FBINCUNK=1 33 . N Y,X 34 . W !! 35 . S DIR("A")="Do you want to include patients whose insurance status is unavailable? " 36 . S DIR("?")="Please answer Yes or No." 37 . S DIR("B")="YES",DIR(0)="YA^^" 38 . D ^DIR K DIR 39 . I $G(DIRUT) S FBINCUNK=-1 Q 40 . I $G(Y)=0 S FBINCUNK=0 41 I FBINCUNK=-1 G EXIT ;uparrow - exit 42 ; 43 DATE ;select date range 44 D DATE^FBAAUTL I FBPOP G PSF 45 S FBBDATE=BEGDATE,FBEDATE=ENDDATE 46 S Z=9999999.9999,FBBEG=Z-FBEDATE,FBEND=Z-FBBDATE 47 Q K ^TMP($J,"FB"),^TMP($J,"FBINSIBAPI"),DIC 48 ; 49 S VAR="FBINCUNK^FBARRLTC^FBARRLTC(^FBPARTY^FBCOPAY^FBNAME^FBIEN^FBID^FBBEG^FBEND^FBBDATE^FBEDATE^FBPSV^FBPSV(^FBPROG(",VAL=VAR,PGM="DQ^FBPCR",IOP="Q" D ZIS^FBAAUTL G:FBPOP EXIT 50 DQ S $P(FBDASH,"=",80)="",$P(FBDASH1,"-",80)="",FBPG=0,FBCRT=$S($E(IOST,1,2)="C-":1,1:0),FBOUT=0,FBBEG=FBBEG-.9 U IO 51 SORT ;sort driver for payment output(s) 52 S FBPI=0 F S FBPI=$O(FBPROG(FBPI)) Q:'FBPI S FBXPROG=FBPROG(FBPI) D 53 .I FBPI=2 D EN^FBPCR2 ;outpatient payments 54 .I FBPI=3 D EN^FBPCR3 ;pharmacy payments 55 .I FBPI=6!(FBPI=7) S:FBPI=6&($D(FBPROG(7))) FBPI=67 D EN^FBPCR67 S:FBPI=67 FBPI=7 ;civil hospital/cnh payments 56 PRINT ;print driver for payment output(s) 57 I $G(^TMP($J,"FBINSIBAPI"))>0 D HDRUNK 58 S FBPI=$O(^TMP($J,"FB",0)) I FBPI']"" D WMSG G OUT 59 S FBSTA=0 60 S FBPSF=0 F S FBPSF=$O(^TMP($J,"FB",FBPSF)) Q:'FBPSF!FBOUT D STA S FBPT="" F S FBPT=$O(^TMP($J,"FB",FBPSF,FBPT)) Q:FBPT']""!FBOUT S DFN=$P(FBPT,";",2) D VET S FBPI=0 F S FBPI=$O(FBPROG(FBPI)) Q:'FBPI S FBXPROG=FBPROG(FBPI) D Q:FBOUT 61 .I FBPSF_FBPT'=FBSTA D HDR Q:FBOUT 62 .I FBPI=2,$D(^TMP($J,"FB",FBPSF,FBPT,FBPI)) D PRINT^FBPCR2 Q 63 .I FBPI=3 D:$D(^TMP($J,"FB",FBPSF,FBPT,FBPI)) PRINT^FBPCR3 Q 64 .I FBPI=6!(FBPI=7) D:$D(^TMP($J,"FB",FBPSF,FBPT,FBPI)) PRINT^FBPCR671 Q 65 OUT I $G(^TMP($J,"FBINSIBAPI"))>0 D ERRHDL^FBPCR4 66 I FBOUT!$D(ZTQUEUED) G EXIT 67 D EXIT G PSF 68 Q 69 EXIT ;kill and quit 70 KILL ;kill all variables set in the FBPCR* routines, other than fbx 71 D CLOSE^FBAAUTL K ^TMP($J,"FB") 72 K A1,A2,A3,BEGDATE,C,D,D2,DFN,DIC,DIR,DTOUT,DUOUT,ENDDATE,FBPDXC,FBPARTY,FBCOPAY,FBARRLTC,FBINCUNK 73 K FBAAA,FBAACPTC,FBAC,FBAP,FBBATCH,FBBDATE,FBBEG,FBBN,FBCATC,FBCNT,FBCP,FBCRT,FBDA1,FBDASH,FBDASH1,FBDATA,FBDOB,FBDRUG,FBDT,FBDT1,FBDOS,FBDX,FBDX1,FBEDATE,FBEND,FBERR,FBFD,FBFD1,FBHEAD 74 K FBI,FBID,FBIEN,FBIN,FBINS,FBINVN,FBIX,FBJ,FBLOC,FBM,FBNAME,FBOB,FBOPI,FBOUT,FBOV,FBP,FBPAT,FBPD,FBPDX,FBPG,FBPI,FBPID,FBPIN,FBPNAME,FBPROC,FBPROC1,FBPROG,FBPSF,FBPSFNAM,FBPSFNUM,FBPSV,FBPT,FBPV,FBQTY,FBREIM,FBRX 75 K FBSC,FBSL,FBSTA,FBSTR,FBSUSP,FBTA,FBTYPE,FBV,FBVCHAIN,FBVEN,FBVENID,FBVNAME,FBVI,FBVID,FBVP,FBXPROG,FBY,FBZ,I,IOP,J,K,L,M,N,PGM,T,V,VA,VAERR,VAL,VAR,VAUTNI,VAUTSTR,VAUTVB,X,Y,Z,FBSTANPI,FBXX 76 Q 77 WMSG ;write message if no matches found 78 D HDR W !!?3,"There are no potential cost recoveries on file" 79 W !?5,"for specified date range: ",$$DATX^FBAAUTL(FBBDATE)," through ",$$DATX^FBAAUTL(FBEDATE) 80 I 'FBPSV D 81 .W ",",!?5,"and selected Primary Service Area(s):" 82 .S FBPSF=0 F S FBPSF=$O(FBPSV(FBPSF)) Q:'FBPSF W !?31,$G(FBPSV(FBPSF)) 83 E W !?5,"and ALL Primary Service Areas " 84 W ".",*7,!! 85 Q 86 ; 87 CATC(DFN,FBDT,FBPOV) ; 88 ;treats all copays as Means test for date < 3020705 (JULY 5,2002) 89 ;check if patient is liable for copay 90 ;INPUT: 91 ; DFN = IEN of Patient file 92 ; FBDT= Date 93 ; FBPOV = POV code (for LTC determination) 94 ;OUTPUT: 95 ;0 - the patient is not liable for any co-pay; 96 ;1 - if Means test catc or pending adjudication and agree to pay deduc 97 ;2 - the patient is liable for LTC co-pay; 98 ;3 - no 1010EC on file 99 ;4 - more analysis is needed to determine the patient liability 100 N FBLTC,FBISLTC 101 S FBCATC=$$BIL^DGMTUB(DFN,FBDT) 102 I '$D(FBPOV)!(FBDT<3020705) Q $S(FBCATC:1,1:0) 103 S FBISLTC=$$ISLTC^FBPCR4(FBPOV) 104 I FBISLTC=0 Q $S(FBCATC:1,1:0) ;Means test 105 I FBISLTC=2 Q 0 ;LTC-service, but LTC-copay is not applicable 106 S FBLTC=$$LTCST^FBPCR4(DFN,FBDT) 107 I FBLTC=2 Q 2 ;LTC copay 108 I FBLTC=0 Q 3 ;no 1010EC on file 109 I FBLTC=4 Q 4 ;more info needed 110 Q 0 ;exemption from LTC -copay 111 ; 112 VET ;set vet name/ssn/dob info 113 ;INPUT: DFN = IEN of Patient file 114 ; FBPI = IEN of fee program (optional) 115 ;OUTPUT: FBPNAME = Patient's name 116 ; FBPID = Patient's pid 117 ; FBDOB = Patient's dob (if pharmacy fee program) 118 N N 119 S N=$G(^DPT(DFN,0)),FBPNAME=$P(N,U),FBPID=$$SSN^FBAAUTL(DFN),FBDOB=$$FMTE^XLFDT($P(N,U,3)) 120 Q 121 STA ;set station name & number 122 ;INPUT = FBPSF - IEN to institution file 123 ;OUTPUT = FBPSFNAM = station name 124 ; FBPSFNUM = station number 125 S FBPSFNAM=$P($G(^DIC(4,FBPSF,0)),U),FBPSFNUM=$P($G(^DIC(4,FBPSF,99)),U) 126 S:FBPSFNAM=+FBPSFNAM FBPSFNAM="UNKNOWN" 127 S FBSTANPI=$S($G(FBPSFNAM)="":"",FBPSFNAM="UNKNOWN":"",1:$P($$NPI^XUSNPI("Organization_ID",FBPSF),U,1)) 128 Q 129 PAGE ;form feed when new station/patient 130 S FBSTA=$G(FBPSF)_$G(FBPT) 131 I FBCRT&(FBPG'=0) D CR Q:FBOUT 132 I FBPG>0!FBCRT W @IOF 133 S FBPG=FBPG+1 134 Q 135 CR ;read for display 136 S DIR(0)="E" W ! D ^DIR K DIR S:$D(DUOUT)!($D(DTOUT)) FBOUT=1 137 Q 138 HDR ;general header for potential recoveries 139 D PAGE Q:FBOUT 140 W !?(IOM-30/2),"POTENTIAL COST RECOVERY REPORT" 141 W !?(IOM-(11+$L($G(FBPSFNAM))+$L($G(FBPSFNUM)))/2),"Division: ",$G(FBPSFNUM)," ",$G(FBPSFNAM) 142 W !?(IOM-14/2),"NPI: ",$S($G(FBSTANPI)="":"",$G(FBSTANPI)=-1:"",1:$G(FBSTANPI)) 143 W !?(IOM-19/2),$$DATX^FBAAUTL(FBBDATE)," - ",$$DATX^FBAAUTL(FBEDATE) 144 W !?71,"Page: ",FBPG 145 W !,"Patient: ",$G(FBPNAME),?40,"Pat. ID: ",$G(FBPID),?62,"DOB: ",$G(FBDOB) 146 W ! 147 I FBINCUNK=1,$D(^TMP($J,"FBINSIBAPI",+$G(DFN))) W ">> Warning: accurate insurance information for the patient is unavailable" 148 W !?3,"('*' Represents Reimbursement to Patient",?50,"'#' Represents Voided Payment)" 149 W !,FBDASH 150 W ! D:$D(DFN) INS^DGRPDB 151 Q 152 HDRUNK ;Warning message if patient's insurance status is unknown 153 D PAGE Q:FBOUT 154 W !?(IOM-30/2),"POTENTIAL COST RECOVERY REPORT" 155 W !?(IOM-(11+$L($G(FBPSFNAM))+$L($G(FBPSFNUM)))/2),"Division: ",$G(FBPSFNUM)," ",$G(FBPSFNAM) 156 W !?(IOM-19/2),$$DATX^FBAAUTL(FBBDATE)," - ",$$DATX^FBAAUTL(FBEDATE) 157 W !?71,"Page: ",FBPG 158 W !,"------------------------------ !!! WARNING !!! --------------------------------" 159 W !,"This report is incomplete due to problems with obtaining insurance information" 160 W !,"for those patients listed in a separate section in the end of the report. You" 161 W !,"may want to rerun the report again to get more accurate results." 162 W !,FBDASH 163 I FBINCUNK=1 D 164 . W !,"Note: You have chosen to include patients with unknown insurance status in" 165 . W !,"this report. Please be aware that these patients will be treated as if they" 166 . W !,"have billable insurance and their treatment details will be marked accordingly." 167 . W !,"The names of these patients will be accompanied with the following message" 168 . W !,"to order to identify them:" 169 . W !,">> Warning: accurate insurance information for the patient is unavailable" 170 . W !,FBDASH 171 Q
Note:
See TracChangeset
for help on using the changeset viewer.
