Index: WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBAA79.m =================================================================== --- WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBAA79.m (revision 613) +++ WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBAA79.m (revision 623) @@ -1,60 +1,55 @@ -FBAA79 ;AISC/GRR-PRINT FORM 7079 REQUEST FOR OUTPATIENT MEDICAL SERVICES ;7/NOV/2006 - ;;3.5;FEE BASIS;**12,23,101,103**;JAN 30, 1995;Build 19 - ;;Per VHA Directive 2004-038, this routine should not be modified. - W !,"Print 7079's for: " D DT^DICRW,DATE^FBAAUTL G:FBPOP END D SITEP^FBAAUTL G:FBPOP END - I '$D(^FBAAA("AF",2)) W !!,*7,"There are no 7079's to be printed!",! G END - S FBAASCR="" -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" - D OUTPUT^FBAAS79 - S VAR="BEGDATE^ENDDATE^FBAASCR",VAL=BEGDATE_"^"_ENDDATE_"^"_FBAASCR,PGM="START^FBAA79",IOP="Q" D ZIS^FBAAUTL G:FBPOP END -START D SITEP^FBAAUTL G END:FBPOP - S UL="",ULL="----------",FBPG=0 F Z=1:1:12 S UL=UL_ULL - 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") - 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 -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 - 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 - D CLOSE^FBAAUTL Q - Q - ; - ; Utilize new API for Name Standardization - ; -GOT Q:'$D(^DPT(DFN,0)) - S Y(0)=^DPT(DFN,0) - D - .N FBNAMES - .S FBNAMES("FILE")=2,FBNAMES("IENS")=DFN_",",FBNAMES("FIELD")=.01 - .S NAME=$$NAMEFMT^XLFNAME(.FBNAMES) - S SEX=$P(Y(0),U,2) - 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:"") - F I=1:1:7 S FBI(I)="" - I $D(^DPT(DFN,.11)) F I=1:1:7 S FBI(I)=$P(^(.11),"^",I) - S POW=$P($G(^DPT(DFN,.52)),"^",5) - 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 - 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) - S NOV=$P($G(^FBAAA(DFN,1,FBK,1)),"^") - S FBDX=$G(^FBAAA(DFN,1,FBK,3)) - S FBIDC=$P($G(^FBAAA(DFN,4)),"^") - S STATCD=FBI(5),CC=FBI(7) F V=1:1:14 S V(V)="" - S CC=$S(CC']"":"",$D(^DIC(5,+STATCD,1,CC,0)):$P(^(0),"^",3),1:"") - 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 - F V=2,1,3,14,4,5,6,10 S V(V)=$P(Y(0),"^",V) -OVR F S=1:1:9 S FBS(S)=$P(FBSITE(0),"^",S) - 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:" ") - 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 - ; - W !,"(1) Veterans Name",?31,"|(2) ID Number | Period of Validity",!,?31,"|",?46,"|" - W !,NAME,?31,"|",?32,SSN,?46,"|"," FROM: ",$$FMTE^XLFDT(VFROM)," TO: ",$$FMTE^XLFDT(VTO),!,UL - W !,"(3) ADDRESS",?31,"|DATE OF ISSUE",?46,"| CONDITIONS FOR WHICH SERVICES ARE REQUESTED (DESCRIPTION OF DISABILITY)",!,?31,"|",?46,"|" - W !,FBI(1),?31,"|",?33,$$FMTE^XLFDT(FBJ),?46,"|"," ",VDX S FBPDX=0 - I FBI(2)]"" W !,FBI(2),?31,"|",?46,"|"," " S FBPDX=FBPDX+1 W ?48,$P(FBDX,"^",FBPDX) - I FBI(3)]"" W !,FBI(3),?31,"|",?46,"|"," " S FBPDX=FBPDX+1 W ?48,$P(FBDX,"^",FBPDX) - 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) - W !,"Name and Address of Fee Participant",?46,"|" S FBPDX=FBPDX+1 W ?48,$P(FBDX,"^",FBPDX) - W !,?46,"|",!,V(1),?46,"|",!,V(3),?46,"|" W:V(14)]"" !,V(14),?46,"|" - ; PRXM/KJH - Patch 103. Add Referring Provider and NPI to the display. - W !,V(4)," ",VSTCD," ",V(6),?46,"|","REFERRING PROVIDER: " - I REF'="" W $$GET1^DIQ(200,REF,.01) - W !,V(2),?46,"|","NPI: ",$$REFNPI^FBCH78(REF,"",1) - W !,?46,"|","AUTHORIZATION #: ",DFN,"-",FBK,!,UL,! - W ?49,"AUTHORIZATION REMARKS",!,?49,$E(UL,1,21) - D ^FBAA79A S $P(^FBAAA(DFN,1,FBK,1),"^",2)=DT,FBPG=1 Q +FBAA79 ;AISC/GRR-PRINT FORM 7079 REQUEST FOR OUTPATIENT MEDICAL SERVICES ;7/NOV/2006 + ;;3.5;FEE BASIS;**12,23,101**;JAN 30, 1995;Build 2 + ;;Per VHA Directive 2004-038, this routine should not be modified. + W !,"Print 7079's for: " D DT^DICRW,DATE^FBAAUTL G:FBPOP END D SITEP^FBAAUTL G:FBPOP END + I '$D(^FBAAA("AF",2)) W !!,*7,"There are no 7079's to be printed!",! G END + S FBAASCR="" +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" + D OUTPUT^FBAAS79 + S VAR="BEGDATE^ENDDATE^FBAASCR",VAL=BEGDATE_"^"_ENDDATE_"^"_FBAASCR,PGM="START^FBAA79",IOP="Q" D ZIS^FBAAUTL G:FBPOP END +START D SITEP^FBAAUTL G END:FBPOP + S UL="",ULL="----------",FBPG=0 F Z=1:1:12 S UL=UL_ULL + 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") + 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 +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 + 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 + D CLOSE^FBAAUTL Q + Q + ; + ; Utilize new API for Name Standardization + ; +GOT Q:'$D(^DPT(DFN,0)) + S Y(0)=^DPT(DFN,0) + D + .N FBNAMES + .S FBNAMES("FILE")=2,FBNAMES("IENS")=DFN_",",FBNAMES("FIELD")=.01 + .S NAME=$$NAMEFMT^XLFNAME(.FBNAMES) + S SEX=$P(Y(0),U,2) + 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:"") + F I=1:1:7 S FBI(I)="" + I $D(^DPT(DFN,.11)) F I=1:1:7 S FBI(I)=$P(^(.11),"^",I) + S POW=$P($G(^DPT(DFN,.52)),"^",5) + 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 + 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)),"^") + S FBDX=$G(^FBAAA(DFN,1,FBK,3)) + S FBIDC=$P($G(^FBAAA(DFN,4)),"^") + S STATCD=FBI(5),CC=FBI(7) F V=1:1:14 S V(V)="" + S CC=$S(CC']"":"",$D(^DIC(5,+STATCD,1,CC,0)):$P(^(0),"^",3),1:"") + 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 + F V=2,1,3,14,4,5,6,10 S V(V)=$P(Y(0),"^",V) +OVR F S=1:1:9 S FBS(S)=$P(FBSITE(0),"^",S) + 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:" ") + 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 + ; + W !,"(1) Veterans Name",?31,"|(2) ID Number | Period of Validity",!,?31,"|",?46,"|" + W !,NAME,?31,"|",?32,SSN,?46,"|"," FROM: ",$$FMTE^XLFDT(VFROM)," TO: ",$$FMTE^XLFDT(VTO),!,UL + W !,"(3) ADDRESS",?31,"|DATE OF ISSUE",?46,"| CONDITIONS FOR WHICH SERVICES ARE REQUESTED (DESCRIPTION OF DISABILITY)",!,?31,"|",?46,"|" + W !,FBI(1),?31,"|",?33,$$FMTE^XLFDT(FBJ),?46,"|"," ",VDX S FBPDX=0 + I FBI(2)]"" W !,FBI(2),?31,"|",?46,"|"," " S FBPDX=FBPDX+1 W ?48,$P(FBDX,"^",FBPDX) + I FBI(3)]"" W !,FBI(3),?31,"|",?46,"|"," " S FBPDX=FBPDX+1 W ?48,$P(FBDX,"^",FBPDX) + 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) + W !,"Name and Address of Fee Participant",?46,"|" S FBPDX=FBPDX+1 W ?48,$P(FBDX,"^",FBPDX) + W !,?46,"|",!,V(1),?46,"|",!,V(3),?46,"|" W:V(14)]"" !,V(14),?46,"|" + W !,V(4)," ",VSTCD," ",V(6),?46,"|",!,V(2),?46,"|","AUTHORIZATION #: ",DFN,"-",FBK,!,UL,! + W ?49,"AUTHORIZATION REMARKS",!,?49,$E(UL,1,21) + D ^FBAA79A S $P(^FBAAA(DFN,1,FBK,1),"^",2)=DT,FBPG=1 Q Index: WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBAA79A.m =================================================================== --- WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBAA79A.m (revision 613) +++ WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBAA79A.m (revision 623) @@ -1,36 +1,30 @@ -FBAA79A ;AISC/GRR-PRINT 7079 CONTINUED ;1/12/98 - ;;3.5;FEE BASIS;**12,103**;JAN 30, 1995;Build 19 - ;;Per VHA Directive 2004-038, this routine should not be modified. - S DIWL=1,DIWF="WC120" K ^UTILITY($J,"W") - 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 - D ^DIWW:$D(FBXX) K FBXX - W !,?40,"FOR VA USE ONLY",!,UL - 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,"|" - W !,?7,FBI(5),?16,"|",?23,CC,?34,"|",?41,FBPATT,?48,"|",?58,YOB,?68,"|",?74,POS,?78,"|",?87,POV,?93,"|",!,UL - W !,"STATION OF JURISDICTION",?48,"|",?78,"|",?80," (11) CODE",?100,"| (12) SEX",!,?48,"|",?78,"|",?100,"|"," ",$S(SEX="F":"FEMALE",1:"MALE") - W !,"Veterans Administration",?48,"|",?78,"|",?100,"|",$E(UL,101,120) - 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" - W:FBS(3)]"" !,FBS(3),?48,"|",?78,"|",?100,"|"," ",$S(POW="Y":"YES",1:"NO") - W !,FBS(4)," ",SSTCD," ",FBS(6),?48,"|",?78,"|",?100,"|" W:FBS(3)']"" " ",$S(POW="Y":"YES",1:"NO") W !,?48,$E(UL,49,120) - W !,?48,"| APPROVED BY (Name and Title)",?110,"(",$S($D(^VA(200,DUZ,0)):$P(^(0),"^",2),1:""),")",!,?48,"|" - W !,"TELEPHONE: ",FBS(7),?48,"|",?50,FBS(8),!,?48,"|",?50,FBS(9),!,UL - W !,?32,"Information On Veterans Administration Program",! - W !,"Acceptance of this request to render the prescribed services will constitute an agreement which is subject",!,"to the following: ",! - W !,?3,"I. SERVICES. If services are not initiated, please return this document to the Station of Jurisdiction with a brief" - W !,?5,"explanation. Unless approved by the VA, services are limited in type and extent to those shown.",! - 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.",! - 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.",! - 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.",! - W !,?3,"V. FEES. Fees claimed may not exceed those made to the general public for like services.",! - W !,?3,"VI. PAYMENT. Payment by the VA for services rendered and approved is payment in full.",! - 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.",! - W !,?3,"VIII. INQUIRIES. Additional information when required may be obtained by contacting the Station Of Jurisdiction.",! - W !,?3,"IX. When submitting claims for payment you must include the NPI and Taxonomy Code of the rendering practitioner, and" - W !,?5,"the NPI and Taxonomy Code of your organization. If, under the HIPAA NPI Final Rule" - W !,?5,"[http://www.cms.hhs.gov/NationalProvIdentStand], your organization is an ""atypical"" provider furnishing services such as" - W !,?5,"taxi, home and vehicle modifications, insect control, habilitation, and respite services and is therefore ineligible" - W !,?5,"for an NPI, it is important that you indicate ""Ineligible for NPI"" on your claim form ." - W !,UL - W !?3,"VA Form 10-7079" - W ?85,"Date Printed: ",$$FMTE^XLFDT(DT),! - Q +FBAA79A ;AISC/GRR-PRINT 7079 CONTINUED ;1/12/98 + ;;3.5;FEE BASIS;**12**;JAN 30, 1995 + ;;Per VHA Directive 10-93-142, this routine should not be modified. + S DIWL=1,DIWF="WC120" K ^UTILITY($J,"W") + 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 + D ^DIWW:$D(FBXX) K FBXX + W !,?40,"FOR VA USE ONLY",!,UL + 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,"|" + W !,?7,FBI(5),?16,"|",?23,CC,?34,"|",?41,FBPATT,?48,"|",?58,YOB,?68,"|",?74,POS,?78,"|",?87,POV,?93,"|",!,UL + W !,"STATION OF JURISDICTION",?48,"|",?78,"|",?80," (11) CODE",?100,"| (12) SEX",!,?48,"|",?78,"|",?100,"|"," ",$S(SEX="F":"FEMALE",1:"MALE") + W !,"Veterans Administration",?48,"|",?78,"|",?100,"|",$E(UL,101,120) + 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" + W:FBS(3)]"" !,FBS(3),?48,"|",?78,"|",?100,"|"," ",$S(POW="Y":"YES",1:"NO") + W !,FBS(4)," ",SSTCD," ",FBS(6),?48,"|",?78,"|",?100,"|" W:FBS(3)']"" " ",$S(POW="Y":"YES",1:"NO") W !,?48,$E(UL,49,120) + W !,?48,"| APPROVED BY (Name and Title)",?110,"(",$S($D(^VA(200,DUZ,0)):$P(^(0),"^",2),1:""),")",!,?48,"|" + W !,"TELEPHONE: ",FBS(7),?48,"|",?50,FBS(8),!,?48,"|",?50,FBS(9),!,UL + W !,?32,"Information On Veterans Administration Program",! + W !,"Acceptance of this request to render the prescribed services will constitute an agreement which is subject",!,"to the following: ",! + W !,?3,"I. SERVICES. If services are not initiated, please return this document to the Station of Jurisdiction with a brief" + W !,?5,"explanation. Unless approved by the VA, services are limited in type and extent to those shown.",! + 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.",! + 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.",! + 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.",! + W !,?3,"V. FEES. Fees claimed may not exceed those made to the general public for like services.",! + W !,?3,"VI. PAYMENT. Payment by the VA for services rendered and approved is payment in full.",! + 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.",! + W !,?3,"VIII. INQUIRIES. Additional information when required may be obtained by contacting the Station Of Jurisdiction.",!,UL + W !?3,"VA Form 10-7079" + W ?85,"Date Printed: ",$$FMTE^XLFDT(DT),! + Q Index: WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBAAAUT.m =================================================================== --- WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBAAAUT.m (revision 613) +++ WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBAAAUT.m (revision 623) @@ -1,58 +1,36 @@ -FBAAAUT ;AISC/DMK - ENTER/EDIT AUTHORIZATION ;3/11/1999 - ;;3.5;FEE BASIS;**13,95,103**;JAN 30, 1995;Build 19 - ;;Per VHA Directive 2004-038, this routine should not be modified. - 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") - W ! S DIC="^DPT(",DIC(0)="QEAZM" D ^DIC G Q:Y<0 S DFN=+Y - I $P($G(^DPT(DFN,.361)),"^")="" W !!,"ELIGIBILITY HAS NOT BEEN DETERMINED NOR PENDING, CANNOT ENTER AN AUTHORIZATION." G FBAAAUT -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.") - 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) -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 - S:'$D(^FBAAA(DFN,1,0)) ^(0)="^161.01D^^" - D ^FBAADEM K DIRUT,DIROUT,DTOUT,DUOUT -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)) - D:'$D(Y)&(HID'="")&(HID'=NID) TRIG K HID,NID,NIDR,TIME G FBAAAUT:FBANEW']"" S X=FBANEW,K=FBD1,J=DT - I FBAAP79="Y" S $P(^FBAAA(DFN,1,FBD1,1),"^",2)="",FBDFN=DFN D CHEKP79 S DFN=FBDFN - 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 - 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 - G FBAAAUT -TRIG ;Add an entry in Fee Basis ID Card Audit file - 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 - S:'$D(^FBAA(161.83,DFN,1,0)) ^(0)="^161.831DA^^" - S %DT="XT",X="NOW" D ^%DT K %DT S TIME=Y - 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 - K DIE,DIC,DA,DLAYGO L -^FBAA(161.83,DFN) - Q -ENT ;ENTRY POINT FROM ^FBAAPM TO CREATE MRA TRANSACTION -MORE ; - S DIC="^FBAA(161.26,",DIC(0)="L",DLAYGO=161.26,X=DFN - S DIC("DR")="1///^S X=""P"";2///^S X=FBD1;3///^S X=FBTTYPE;5////^S X=FBFDC;6////^S X=FBMST" - K DD,DO D FILE^DICN K DIC,DLAYGO S DA=+Y - Q - ; -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 - Q -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 - K FBAUT,FBD1,FBPOP - Q - ; - ; PROVIDER LOOKUP - ; - ; This function checks the inputed File 200 entry to ensure that it has been assigned the Security Key PROVIDER. - ; - ; Referenced: AUTHORIZATION Sub-File (#161.01) OF FEE BASIS PATIENT File (#161) - REFERRING PROVIDER Field (#104) - ; Referenced: FEE NOTIFICATION/REQUEST File (#162.2) - REFERRING PROVIDER Field (#17) - ; Referenced: VA FORM 10-7078 File (#162.4) - REFERRING PROVIDER Field (#15) - ; - ; Input - FB200IEN - Internal IEN of file 200 entry - ; Output - 0 Blank Input or entry without PROVIDER Security Key - ; - 1 Entry PROVIDER Security Key assigned - ; -PROVIDER(FB200IEN) N Y - ; - Q:$G(FB200IEN)="" 0 - ; - ;Test for PROVIDER Security Key - I $D(^XUSEC("PROVIDER",FB200IEN)) Q 1 - ; - ;Entry did not have PROVIDER Security Key - Q 0 +FBAAAUT ;AISC/DMK-ENTER/EDIT AUTHORIZATION ;3/11/1999 + ;;3.5;FEE BASIS;**13,95**;JAN 30, 1995 + ;;Per VHA Directive 10-93-142, this routine should not be modified. + 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") + W ! S DIC="^DPT(",DIC(0)="QEAZM" D ^DIC G Q:Y<0 S DFN=+Y + I $P($G(^DPT(DFN,.361)),"^")="" W !!,"ELIGIBILITY HAS NOT BEEN DETERMINED NOR PENDING, CANNOT ENTER AN AUTHORIZATION." G FBAAAUT +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.") + 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) +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 + S:'$D(^FBAAA(DFN,1,0)) ^(0)="^161.01D^^" + D ^FBAADEM K DIRUT,DIROUT,DTOUT,DUOUT +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)) + D:'$D(Y)&(HID'="")&(HID'=NID) TRIG K HID,NID,NIDR,TIME G FBAAAUT:FBANEW']"" S X=FBANEW,K=FBD1,J=DT + I FBAAP79="Y" S $P(^FBAAA(DFN,1,FBD1,1),"^",2)="",FBDFN=DFN D CHEKP79 S DFN=FBDFN + 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 + 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 + G FBAAAUT +TRIG ;Add an entry in Fee Basis ID Card Audit file + 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 + S:'$D(^FBAA(161.83,DFN,1,0)) ^(0)="^161.831DA^^" + S %DT="XT",X="NOW" D ^%DT K %DT S TIME=Y + 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 + K DIE,DIC,DA,DLAYGO L -^FBAA(161.83,DFN) + Q +ENT ;ENTRY POINT FROM ^FBAAPM TO CREATE MRA TRANSACTION +MORE ; + S DIC="^FBAA(161.26,",DIC(0)="L",DLAYGO=161.26,X=DFN + S DIC("DR")="1///^S X=""P"";2///^S X=FBD1;3///^S X=FBTTYPE;5////^S X=FBFDC;6////^S X=FBMST" + K DD,DO D FILE^DICN K DIC,DLAYGO S DA=+Y + Q + ; +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 + Q +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 + K FBAUT,FBD1,FBPOP + Q Index: WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBAADEM1.m =================================================================== --- WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBAADEM1.m (revision 613) +++ WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBAADEM1.m (revision 623) @@ -1,52 +1,48 @@ -FBAADEM1 ;AISC/DMK-DISPLAY PATIENT DEMOGRAPHICS ;14MAY92 - ;;3.5;FEE BASIS;**13,51,103**;JAN 30, 1995;Build 19 - ;;Per VHA Directive 2004-038, this routine should not be modified. -EN N FBDX,FBFDT,FBI,FBRR,FBT,FBTYPE,FBV,FBZ,PSA - S:'$D(FBPROG) FBPROG="I 1" - ; - 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,! - ; - I $O(^FBAAA(DFN,1,0)) D Q:FBAAOUT - . D HANG:$Y+5>IOSL Q:FBAAOUT - . W !,"Patient Name: ",VADM(1),?55,"Pt.ID: ",$P(VADM(2),"^",2) - . W !!,"AUTHORIZATIONS:",! - . K FBAUT - . S FBZ=0,FBFDT="9999999" - . F S FBFDT=$O(^FBAAA(DFN,1,"B",FBFDT),-1) Q:'FBFDT D Q:FBAAOUT - . . 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 - . . . S Y=+X,PSA=$P(X,"^",5),FBT=$P(X,"^",13),FBV=+$P(X,"^",4) D PDF - . . . W ?3,"(",FBZ,")",?7,"FR: ",Y,?25,"VENDOR: ",$S($D(^FBAAV(FBV,0)):$P(^(0),"^")_" - "_$P(^(0),"^",2),1:"Not Specified") - . . . S FBDX=$G(^FBAAA(DFN,1,FBI,3)) W !?7,"TO: " S Y=$P(X,"^",2) D PDF W Y,!?25,"Authorization Type: " D - . . . . 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") - . . . 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 <<" - . . . ; PRXM/KJH - Patch 103. Add Referring Provider and NPI to the display. - . . . W !?11,"DX: ",$P(X,"^",8) W ?40,"REF: " - . . . I $P(X,"^",21)'="" W $$GET1^DIQ(200,$P(X,"^",21),.01) - . . . W !?11,"REF NPI: ",$$REFNPI^FBCH78($P(X,"^",21)),! - . . . W:$P(FBDX,"^")]"" !?15,$P(FBDX,"^") W:$P(FBDX,"^",2)]"" !?15,$P(FBDX,"^",2) - . . . S FBAUT($P(X,"^"))=$P(X,"^",2) - . . . W !?7,"County: ",FBCOUNTY,?40,"PSA: ",$S($D(^DIC(4,+PSA,0)):$P(^(0),"^"),1:"Unknown"),! - . . . 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," >>",! - . . . 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 - . . . . S FBRR=0 F S FBRR=$O(^FBAAA(DFN,1,FBI,2,FBRR)) Q:'FBRR S (FBXX,X)=^(FBRR,0) D ^DIWP - . . . D ^DIWW:$D(FBXX) K FBXX W ! - . . . K X,FBDX,FBT,FBTYPE,FBV,PSA D HANG:$Y+5>IOSL - ; - D HANG:$Y+5>IOSL Q:FBAAOUT - ; - I $O(^FBAAA(DFN,2,0))>0 D Q:FBAAOUT - . W !,"VENDOR CONTACTS:" - . S (FBZ,FBI)=0 - . F S FBI=$O(^FBAAA(DFN,2,FBI)) Q:'FBI!(FBAAOUT) S FBZ=FBZ+1,X=$G(^(FBI,0)),Y=+X D PDF D - . . W !?3,"(",FBZ,")",?7,"DATE: ",Y,?25,"VENDOR: ",$P(X,"^",2),?55,"PHONE: ",$S($P(X,"^",3)]"":$P(X,"^",3),1:"Not Found") - . . 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 - . . . 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 - . . D ^DIWW:$D(FBXX) K FBXX W ! - Q - ; -HANG I $E(IOST,1,2)="C-" S DIR(0)="E" D ^DIR K DIR S:'Y FBAAOUT=1 - W @IOF I 'FBAAOUT W !,"Patient Name: ",VADM(1),?55,"Pt.ID: ",$P(VADM(2),"^",2),! - Q - ; -PDF S:Y Y=$$FMTE^XLFDT(Y,5) ; TRANSLATE TO DISPLAY DATE - Q +FBAADEM1 ;AISC/DMK-DISPLAY PATIENT DEMOGRAPHICS ;14MAY92 + ;;3.5;FEE BASIS;**13,51**;JAN 30, 1995 + ;;Per VHA Directive 10-93-142, this routine should not be modified. +EN N FBDX,FBFDT,FBI,FBRR,FBT,FBTYPE,FBV,FBZ,PSA + S:'$D(FBPROG) FBPROG="I 1" + ; + 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,! + ; + I $O(^FBAAA(DFN,1,0)) D Q:FBAAOUT + . D HANG:$Y+5>IOSL Q:FBAAOUT + . W !,"Patient Name: ",VADM(1),?55,"Pt.ID: ",$P(VADM(2),"^",2) + . W !!,"AUTHORIZATIONS:",! + . K FBAUT + . S FBZ=0,FBFDT="9999999" + . F S FBFDT=$O(^FBAAA(DFN,1,"B",FBFDT),-1) Q:'FBFDT D Q:FBAAOUT + . . 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 + . . . S Y=+X,PSA=$P(X,"^",5),FBT=$P(X,"^",13),FBV=+$P(X,"^",4) D PDF + . . . W ?3,"(",FBZ,")",?7,"FR: ",Y,?25,"VENDOR: ",$S($D(^FBAAV(FBV,0)):$P(^(0),"^")_" - "_$P(^(0),"^",2),1:"Not Specified") + . . . S FBDX=$G(^FBAAA(DFN,1,FBI,3)) W !?7,"TO: " S Y=$P(X,"^",2) D PDF W Y,!?25,"Authorization Type: " D + . . . . 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") + . . . 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 <<" + . . . W !?11,"DX: ",$P(X,"^",8) W:$P(FBDX,"^")]"" !?15,$P(FBDX,"^") W:$P(FBDX,"^",2)]"" !?15,$P(FBDX,"^",2) + . . . S FBAUT($P(X,"^"))=$P(X,"^",2) + . . . W !?7,"County: ",FBCOUNTY,?40,"PSA: ",$S($D(^DIC(4,+PSA,0)):$P(^(0),"^"),1:"Unknown"),! + . . . 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," >>",! + . . . 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 + . . . . S FBRR=0 F S FBRR=$O(^FBAAA(DFN,1,FBI,2,FBRR)) Q:'FBRR S (FBXX,X)=^(FBRR,0) D ^DIWP + . . . D ^DIWW:$D(FBXX) K FBXX W ! + . . . K X,FBDX,FBT,FBTYPE,FBV,PSA D HANG:$Y+5>IOSL + ; + D HANG:$Y+5>IOSL Q:FBAAOUT + ; + I $O(^FBAAA(DFN,2,0))>0 D Q:FBAAOUT + . W !,"VENDOR CONTACTS:" + . S (FBZ,FBI)=0 + . F S FBI=$O(^FBAAA(DFN,2,FBI)) Q:'FBI!(FBAAOUT) S FBZ=FBZ+1,X=$G(^(FBI,0)),Y=+X D PDF D + . . W !?3,"(",FBZ,")",?7,"DATE: ",Y,?25,"VENDOR: ",$P(X,"^",2),?55,"PHONE: ",$S($P(X,"^",3)]"":$P(X,"^",3),1:"Not Found") + . . 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 + . . . 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 + . . D ^DIWW:$D(FBXX) K FBXX W ! + Q + ; +HANG I $E(IOST,1,2)="C-" S DIR(0)="E" D ^DIR K DIR S:'Y FBAAOUT=1 + W @IOF I 'FBAAOUT W !,"Patient Name: ",VADM(1),?55,"Pt.ID: ",$P(VADM(2),"^",2),! + Q + ; +PDF S:Y Y=$$FMTE^XLFDT(Y,5) ; TRANSLATE TO DISPLAY DATE + Q Index: WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBAAFSR.m =================================================================== --- WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBAAFSR.m (revision 613) +++ WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBAAFSR.m (revision 623) @@ -1,229 +1,225 @@ -FBAAFSR ;WCIOFO/TCK,SS,DMK,SAB-RBRVS FEE SCHEDULE ; 8/26/1999 - ;;3.5;FEE BASIS;**4,53,71,84,92,93,99,102,105**;JAN 30, 1995;Build 1 - ; - Q - ; -RBRVS(CPT,MODL,DOS,ZIP,FAC,TIME) ; calculate RBRVS Fee Schedule amount - ; Input - ; CPT = CPT/HCPCS code (external value) - ; MODL = list of CPT/HCPCS modifiers (external values) - ; delimited by commas (e.g. "26,51") - ; DOS = date of service (fileman format e.g. 2980101) - ; ZIP = ZIP code of service (external 5 digit value) - ; FAC = facility flag =1 if site of service is facility setting - ; TIME = time in minutes, only passed on anesthesia CPT codes - ; Returns string - ; dollar amount^sched year OR null value if not on RBRVS schedule - ; Output - ; FBERR( array of error messages OR undefined if none - ; - N FBAMT,FBCF,FBCPT0,FBCPTY0,FBCY,FBERR,FBGPCIY0 - ; - ; initialization - S FBAMT="" - K FBERR - ; - ; check for required input parameters - I $G(CPT)="" D ERR^FBAAFS("CPT missing") - I $G(DOS)'?7N D ERR^FBAAFS("Date of Service missing") - I $D(FBERR) Q FBAMT - ; - ;if date of service prior to VA implementation, don't use RBRVS - I DOS<2990901 Q FBAMT - ; - ;if modifier SG present, don't use RBRVS, patch FB*3.5*84 - I MODL["SG" Q FBAMT - ; - ; determine schedule calendar year based on date of service - S FBCY=$E(DOS,1,3)+1700 - ; - ;If date of service in 2003 but prior to Mar 1, 2003 treat as 2002 - I $E(DOS,1,3)=303,DOS<3030301 S FBCY=FBCY-1 - ; - ; if year after most recent RBRVS schedule then use prior year schedule - I FBCY>$$LASTCY() S FBCY=FBCY-1 - ; - ; get procedure data from schedule for year - D PROC(CPT,MODL,FBCY) - ; - ; if procedure: - ; - covered - ; - payable - ; - not for anesthesia - ; then calculate amount - I FBCPTY0]"",'$$ANES^FBAAFS(CPT) D - . ; - . ;validate parameters - . I $G(ZIP)="" D ERR^FBAAFS("Missing ZIP Code") - . I $G(FAC)="" D ERR^FBAAFS("Missing Facility Flag") - . I $D(FBERR) Q - . ; - . ; get GPCIs for calendar year - . D ZIP(FBCY,ZIP) - . I FBGPCIY0="" D ERR^FBAAFS("Could not determine GPCIs") Q - . ; - . ; get conversion factor - . S FBCF=$$CF(FBCY,$P(FBCPT0,U,2)) - . I FBCF="" D ERR^FBAAFS("Could not determine the conversion factor") Q - . ; - . ; calculate full schedule amount - . D CALC(FBCY,FAC,FBCPTY0,FBGPCIY0,FBCF) - . ; - . ; apply multiplier based on modifier - . I MODL]"" S FBAMT=FBAMT*$$MULT(FBCY,MODL,FBCPT0,FBCPTY0) - ; - ; return result - Q $S(FBAMT>0:$J(FBAMT,0,2)_U_FBCY,1:"") - ; -PROC(CPT,MODL,FBCY,FBNONPBL) ; get procedure data for RBRVS schedule - ; Input - ; CPT = CPT/HCPCS code (external value) - ; MODL = list of CPT/HCPCS modifiers (external value) - ; delimited by commas - ; FBCY = calendar year (4 digit) - ; FBNONPBL ( optional): - ; if $G(FBNONPBL)=0 then will make search among payable records only in #162.97 - ; ignoring those non-payable ones with field #.08 NONPAYABLE = 1 - ; if $G(FBNONPBL)=1 then will make search among all items in #162.97 - ; - ; Output - ; FBCPT0 = zero node from file 162.97 OR "" if not covered - ; FBCPTY0 = zero node from subfile 162.971 or "" if not covered - N CPTM,MOD,FBI - S (FBCPT0,FBCPTY0)="" - Q:$G(FBCY)']""!($G(CPT)']"") - ; - ; if modifier exists try to find entry with modifier - I MODL]"" D - . F FBI=1:1 S MOD=$P(MODL,",",FBI) Q:MOD="" D Q:FBCPTY0]"" - . . S CPTM=CPT_"-"_MOD - . . D PROC1(CPTM,FBCY,$G(FBNONPBL)) - ; - ; if not found with modifier, try just CPT code - I FBCPTY0="" D PROC1(CPT,FBCY,$G(FBNONPBL)) - ; - Q - ; -PROC1(CPTM,FBCY,FBNONPBL) ; get procedure data for CPT-Modifier - ; input - ; CPTM - CPT Code - Modifier (e.g. 57335-TC or 57335) - ; FBCY - 4 digit calendar year - ; FBNONPBL ( optional): - ; if $G(FBNONPBL)=0 then will make search among payable records only in #162.97 - ; ignoring those non-payable ones with field #.08 NONPAYABLE = 1 - ; if $G(FBNONPBL)=1 then will make search among all items in #162.97 - ; output - ; FBCPT0 = zero node from file 162.97 OR "" if not covered - ; FBCPTY0 = zero node from subfile 162.971 or "" if not covered - N FBDA,FBDA1 - S (FBCPT0,FBCPTY0)="" - S FBDA=$O(^FB(162.97,"B",CPTM,0)) - S FBDA1=$S(FBDA:$O(^FB(162.97,FBDA,"CY","B",FBCY,0)),1:"") - I $G(FBDA),$G(FBDA1) D - . N FBI,FBSUM,FBY - . S FBY=$G(^FB(162.97,FBDA,"CY",FBDA1,0)) - . ;if non-payable records should not be considered - . ;then quit if this is NONPAYBLE - . I +$G(FBNONPBL)=0 Q:$P(FBY,U,8)=1 - . ; check if procedure covered by schedule - . I +$G(FBNONPBL)=0,$$ANES^FBAAFS($P(CPTM,"-")),$P(FBY,U,6)']"" Q ; missing anes base - . I +$G(FBNONPBL)=0,'$$ANES^FBAAFS($P(CPTM,"-")) D I FBSUM'>0 Q ; sum of RVUs = 0 - . . S FBSUM=0 F FBI=3,4,5,6 S FBSUM=FBSUM+$P(FBY,U,FBI) - . ; passed checks - . S FBCPTY0=FBY - . S FBCPT0=$G(^FB(162.97,FBDA,0)) - Q - ; -ZIP(FBCY,ZIP) ; get GPCIs - ; Input - ; FBCY = calendar year (4 digit) - ; ZIP = zip code (5 digit external value) - ; Output - ; FBGPCIY0 = zero node from file 162.96 or "" if not found - S FBGPCIY0="" - Q:$G(FBCY)']""!($G(ZIP)']"") - N FBDA,FBDA1 - S FBDA=$O(^FB(162.96,"B",ZIP,0)) - S FBDA1=$S(FBDA:$O(^FB(162.96,FBDA,"CY","B",FBCY,0)),1:"") - I FBDA,FBDA1 S FBGPCIY0=$G(^FB(162.96,FBDA,"CY",FBDA1,0)) - Q - ; -CF(FBCY,FBDA) ; get conversion factor - ; Input - ; FBCY = calendar year - ; FBDA = optional conversion category (internal) - ; Returns - ; conversion factor from file 162.99 - N FBCF,FBDA1 - I '$G(FBDA) S FBDA=4 ; use Medicine category if not specified - S FBDA1=$O(^FB(162.99,FBDA,"CY","B",FBCY,0)) - S FBCF=$S(FBDA1:$P($G(^FB(162.99,FBDA,"CY",FBDA1,0)),U,2),1:"") - Q +FBCF - ; -CALC(FBCY,FAC,FBCPTY0,FBGPCIY0,FBCF) ; - ; Input - ; FBCY = calendar year (4 digit) - ; FAC = facility flag (0 or 1) - ; FBCPTY0 = zero node from file 162.71 - ; FBGPCI0 = zero node from file 162.61 - ; FBCF = conversion factor (number) - ; Returns $ amount - ; - N GPCI,RVU,FBI,TMP,TMPRVU - S FBAMT=0 - ;Old formula for RBRVS pre-2007 payment amounts - I DOS<3070101 D - .S RVU(1)=$P(FBCPTY0,U,3) - I (DOS=3070101!(DOS>3070101)&(DOS<3080101)) D - .;New formula for RBRVS 2007 payment amounts - .;Multiply Work RVU by the Budget Neutrality Adjustor (0.8994) - .S TMP=$P(FBCPTY0,U,3),TMPRVU=$J((TMP*(.8994)),".",2) - .S RVU(1)=TMPRVU - I DOS=3080101!(DOS>3080101) D - .;New formula for the RBRVS 2008 payment amounts - .;Multiply Work RVU by the Budget Neutrality Adjustor (0.8994) - .S TMP=$P(FBCPTY0,U,3),TMPRVU=$J((TMP*(.8806)),".",2) - .S RVU(1)=TMPRVU - S RVU(2)=$P(FBCPTY0,U,4+FAC) - S RVU(3)=$P(FBCPTY0,U,6) - F FBI=2,3,4 S GPCI(FBI-1)=$P(FBGPCIY0,U,FBI) - S FBAMT=((RVU(1)*GPCI(1))+(RVU(2)*GPCI(2))+(RVU(3)*GPCI(3)))*FBCF - ; some procedures can't be performed in a facility setting by - ; definition. the facility PE RVU for such a procedure is a null - ; value. - ; when facility setting - check for a null PE value and don't return amt - I RVU(2)="",FAC S FBAMT=0 Q - Q - ; -MULT(FBCY,MODL,FBCPT0,FBCPTY0) ;returns multiplier based on table type - ; Input - ; FBCY = calendar year (4 digit) - ; MODL = list of CPT/HCPCS modifiers (external values) - ; delimited by commas - ; FBCPT0 = zero node of file 162.7 for procedure - ; FBCPTY0 = zero node of subfile 162.71 for year - ; Returns - ; multiplier value OR 1 if none - N FBDA,FBDA1,FBI,FBML,FBPD,FBRET,FBTBL,MOD - S FBRET=1 - S FBML=$P(FBCPTY0,U,2) ; mod level table for procedure - I MODL]"",FBML]"",FBCY]"" D - . S FBTBL=FBCY_"-"_FBML ; mod level table for year - . S FBDA=$O(^FB(162.98,"B",FBTBL,0)) - . Q:'FBDA ; table not found - . ; loop thru the modifiers - . F FBI=1:1 S MOD=$P(MODL,",",FBI) Q:MOD="" D - . . I $P($P(FBCPT0,U),"-",2)=MOD Q ; modifier already built in schedule - . . ; look up modifier in mod level table - . . S FBDA1=$O(^FB(162.98,FBDA,"M","B",MOD,0)) - . . Q:'FBDA1 ; modifier not found in table - . . S FBPD=$P($G(^FB(162.98,FBDA,"M",FBDA1,0)),U,2) ; percentage - . . I FBPD>0 S FBRET=FBRET*(FBPD/100) ; multiplier - Q FBRET - ; -LASTCY() ; Determine last calendar year of RBRVS FEE schedule data - ; based on last year for Medicine conversion factor - N YEAR - S YEAR=$O(^FB(162.99,4,"CY","B"," "),-1) - Q YEAR - ;FBAAFSR +FBAAFSR ;WCIOFO/TCK,SS,DMK,SAB-RBRVS FEE SCHEDULE ; 8/26/1999 + ;;3.5;FEE BASIS;**4,53,71,84,92,93,99,102**;JAN 30, 1995;Build 24 + ; + Q + ; +RBRVS(CPT,MODL,DOS,ZIP,FAC,TIME) ; calculate RBRVS Fee Schedule amount + ; Input + ; CPT = CPT/HCPCS code (external value) + ; MODL = list of CPT/HCPCS modifiers (external values) + ; delimited by commas (e.g. "26,51") + ; DOS = date of service (fileman format e.g. 2980101) + ; ZIP = ZIP code of service (external 5 digit value) + ; FAC = facility flag =1 if site of service is facility setting + ; TIME = time in minutes, only passed on anesthesia CPT codes + ; Returns string + ; dollar amount^sched year OR null value if not on RBRVS schedule + ; Output + ; FBERR( array of error messages OR undefined if none + ; + N FBAMT,FBCF,FBCPT0,FBCPTY0,FBCY,FBERR,FBGPCIY0 + ; + ; initialization + S FBAMT="" + K FBERR + ; + ; check for required input parameters + I $G(CPT)="" D ERR^FBAAFS("CPT missing") + I $G(DOS)'?7N D ERR^FBAAFS("Date of Service missing") + I $D(FBERR) Q FBAMT + ; + ;if date of service prior to VA implementation, don't use RBRVS + I DOS<2990901 Q FBAMT + ; + ;if modifier SG present, don't use RBRVS, patch FB*3.5*84 + I MODL["SG" Q FBAMT + ; + ; determine schedule calendar year based on date of service + S FBCY=$E(DOS,1,3)+1700 + ; + ;If date of service in 2003 but prior to Mar 1, 2003 treat as 2002 + I $E(DOS,1,3)=303,DOS<3030301 S FBCY=FBCY-1 + ; + ; if year after most recent RBRVS schedule then use prior year schedule + I FBCY>$$LASTCY() S FBCY=FBCY-1 + ; + ; get procedure data from schedule for year + D PROC(CPT,MODL,FBCY) + ; + ; if procedure: + ; - covered + ; - payable + ; - not for anesthesia + ; then calculate amount + I FBCPTY0]"",'$$ANES^FBAAFS(CPT) D + . ; + . ;validate parameters + . I $G(ZIP)="" D ERR^FBAAFS("Missing ZIP Code") + . I $G(FAC)="" D ERR^FBAAFS("Missing Facility Flag") + . I $D(FBERR) Q + . ; + . ; get GPCIs for calendar year + . D ZIP(FBCY,ZIP) + . I FBGPCIY0="" D ERR^FBAAFS("Could not determine GPCIs") Q + . ; + . ; get conversion factor + . S FBCF=$$CF(FBCY,$P(FBCPT0,U,2)) + . I FBCF="" D ERR^FBAAFS("Could not determine the conversion factor") Q + . ; + . ; calculate full schedule amount + . D CALC(FBCY,FAC,FBCPTY0,FBGPCIY0,FBCF) + . ; + . ; apply multiplier based on modifier + . I MODL]"" S FBAMT=FBAMT*$$MULT(FBCY,MODL,FBCPT0,FBCPTY0) + ; + ; return result + Q $S(FBAMT>0:$J(FBAMT,0,2)_U_FBCY,1:"") + ; +PROC(CPT,MODL,FBCY,FBNONPBL) ; get procedure data for RBRVS schedule + ; Input + ; CPT = CPT/HCPCS code (external value) + ; MODL = list of CPT/HCPCS modifiers (external value) + ; delimited by commas + ; FBCY = calendar year (4 digit) + ; FBNONPBL ( optional): + ; if $G(FBNONPBL)=0 then will make search among payable records only in #162.97 + ; ignoring those non-payable ones with field #.08 NONPAYABLE = 1 + ; if $G(FBNONPBL)=1 then will make search among all items in #162.97 + ; + ; Output + ; FBCPT0 = zero node from file 162.97 OR "" if not covered + ; FBCPTY0 = zero node from subfile 162.971 or "" if not covered + N CPTM,MOD,FBI + S (FBCPT0,FBCPTY0)="" + Q:$G(FBCY)']""!($G(CPT)']"") + ; + ; if modifier exists try to find entry with modifier + I MODL]"" D + . F FBI=1:1 S MOD=$P(MODL,",",FBI) Q:MOD="" D Q:FBCPTY0]"" + . . S CPTM=CPT_"-"_MOD + . . D PROC1(CPTM,FBCY,$G(FBNONPBL)) + ; + ; if not found with modifier, try just CPT code + I FBCPTY0="" D PROC1(CPT,FBCY,$G(FBNONPBL)) + ; + Q + ; +PROC1(CPTM,FBCY,FBNONPBL) ; get procedure data for CPT-Modifier + ; input + ; CPTM - CPT Code - Modifier (e.g. 57335-TC or 57335) + ; FBCY - 4 digit calendar year + ; FBNONPBL ( optional): + ; if $G(FBNONPBL)=0 then will make search among payable records only in #162.97 + ; ignoring those non-payable ones with field #.08 NONPAYABLE = 1 + ; if $G(FBNONPBL)=1 then will make search among all items in #162.97 + ; output + ; FBCPT0 = zero node from file 162.97 OR "" if not covered + ; FBCPTY0 = zero node from subfile 162.971 or "" if not covered + N FBDA,FBDA1 + S (FBCPT0,FBCPTY0)="" + S FBDA=$O(^FB(162.97,"B",CPTM,0)) + S FBDA1=$S(FBDA:$O(^FB(162.97,FBDA,"CY","B",FBCY,0)),1:"") + I $G(FBDA),$G(FBDA1) D + . N FBI,FBSUM,FBY + . S FBY=$G(^FB(162.97,FBDA,"CY",FBDA1,0)) + . ;if non-payable records should not be considered + . ;then quit if this is NONPAYBLE + . I +$G(FBNONPBL)=0 Q:$P(FBY,U,8)=1 + . ; check if procedure covered by schedule + . I +$G(FBNONPBL)=0,$$ANES^FBAAFS($P(CPTM,"-")),$P(FBY,U,6)']"" Q ; missing anes base + . I +$G(FBNONPBL)=0,'$$ANES^FBAAFS($P(CPTM,"-")) D I FBSUM'>0 Q ; sum of RVUs = 0 + . . S FBSUM=0 F FBI=3,4,5,6 S FBSUM=FBSUM+$P(FBY,U,FBI) + . ; passed checks + . S FBCPTY0=FBY + . S FBCPT0=$G(^FB(162.97,FBDA,0)) + Q + ; +ZIP(FBCY,ZIP) ; get GPCIs + ; Input + ; FBCY = calendar year (4 digit) + ; ZIP = zip code (5 digit external value) + ; Output + ; FBGPCIY0 = zero node from file 162.96 or "" if not found + S FBGPCIY0="" + Q:$G(FBCY)']""!($G(ZIP)']"") + N FBDA,FBDA1 + S FBDA=$O(^FB(162.96,"B",ZIP,0)) + S FBDA1=$S(FBDA:$O(^FB(162.96,FBDA,"CY","B",FBCY,0)),1:"") + I FBDA,FBDA1 S FBGPCIY0=$G(^FB(162.96,FBDA,"CY",FBDA1,0)) + Q + ; +CF(FBCY,FBDA) ; get conversion factor + ; Input + ; FBCY = calendar year + ; FBDA = optional conversion category (internal) + ; Returns + ; conversion factor from file 162.99 + N FBCF,FBDA1 + I '$G(FBDA) S FBDA=4 ; use Medicine category if not specified + S FBDA1=$O(^FB(162.99,FBDA,"CY","B",FBCY,0)) + S FBCF=$S(FBDA1:$P($G(^FB(162.99,FBDA,"CY",FBDA1,0)),U,2),1:"") + Q +FBCF + ; +CALC(FBCY,FAC,FBCPTY0,FBGPCIY0,FBCF) ; + ; Input + ; FBCY = calendar year (4 digit) + ; FAC = facility flag (0 or 1) + ; FBCPTY0 = zero node from file 162.71 + ; FBGPCI0 = zero node from file 162.61 + ; FBCF = conversion factor (number) + ; Returns $ amount + ; + N GPCI,RVU,FBI,TMP,TMPRVU + S FBAMT=0 + ;Multiply Work RVU by the Budget Neutrality Adjustor (0.8994) + I DOS<3070101 D + .;Old formula for RBRVS pre-2007 payment amounts + .S RVU(1)=$P(FBCPTY0,U,3) + I DOS>3061231 D + .;New formula for RBRVS 2007 payment amounts + .;Multiply Work RVU by the Budget Neutrality Adjustor (0.8994) + .S TMP=$P(FBCPTY0,U,3),TMPRVU=$J((TMP*(.8994)),".",2) + .S RVU(1)=TMPRVU + S RVU(2)=$P(FBCPTY0,U,4+FAC) + S RVU(3)=$P(FBCPTY0,U,6) + F FBI=2,3,4 S GPCI(FBI-1)=$P(FBGPCIY0,U,FBI) + S FBAMT=((RVU(1)*GPCI(1))+(RVU(2)*GPCI(2))+(RVU(3)*GPCI(3)))*FBCF + ; some procedures can't be performed in a facility setting by + ; definition. the facility PE RVU for such a procedure is a null + ; value. + ; when facility setting - check for a null PE value and don't return amt + I RVU(2)="",FAC S FBAMT=0 Q + Q + ; +MULT(FBCY,MODL,FBCPT0,FBCPTY0) ;returns multiplier based on table type + ; Input + ; FBCY = calendar year (4 digit) + ; MODL = list of CPT/HCPCS modifiers (external values) + ; delimited by commas + ; FBCPT0 = zero node of file 162.7 for procedure + ; FBCPTY0 = zero node of subfile 162.71 for year + ; Returns + ; multiplier value OR 1 if none + N FBDA,FBDA1,FBI,FBML,FBPD,FBRET,FBTBL,MOD + S FBRET=1 + S FBML=$P(FBCPTY0,U,2) ; mod level table for procedure + I MODL]"",FBML]"",FBCY]"" D + . S FBTBL=FBCY_"-"_FBML ; mod level table for year + . S FBDA=$O(^FB(162.98,"B",FBTBL,0)) + . Q:'FBDA ; table not found + . ; loop thru the modifiers + . F FBI=1:1 S MOD=$P(MODL,",",FBI) Q:MOD="" D + . . I $P($P(FBCPT0,U),"-",2)=MOD Q ; modifier already built in schedule + . . ; look up modifier in mod level table + . . S FBDA1=$O(^FB(162.98,FBDA,"M","B",MOD,0)) + . . Q:'FBDA1 ; modifier not found in table + . . S FBPD=$P($G(^FB(162.98,FBDA,"M",FBDA1,0)),U,2) ; percentage + . . I FBPD>0 S FBRET=FBRET*(FBPD/100) ; multiplier + Q FBRET + ; +LASTCY() ; Determine last calendar year of RBRVS FEE schedule data + ; based on last year for Medicine conversion factor + N YEAR + S YEAR=$O(^FB(162.99,4,"CY","B"," "),-1) + Q YEAR + ;FBAAFSR Index: WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBCH78.m =================================================================== --- WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBCH78.m (revision 613) +++ WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBCH78.m (revision 623) @@ -1,98 +1,56 @@ -FBCH78 ;AISC/DMK-SETS UP 7078/AUTHORIZATION FOR CONTRACT HOSPITAL ;08/07/02 - ;;3.5;FEE BASIS;**43,103**;JAN 30, 1995;Build 19 - ;;Per VHA Directive 2004-038, this routine should not be modified. - 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)) - 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 -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) - ;FB*3.5*103 ;added FBRP - S FBRP=$P($G(^FBAA(162.2,FBDA,2)),"^") K DA - W !! S %DT="APEX",%DT("A")="AUTHORIZATION TO DATE: " D ^%DT K %DT G END:X="^" S FBTODT=$S(X="":"",1:Y) - I FBTODT]"",FBFRDT>FBTODT W !!,*7,?5,"Authorization To Date must be after Authorization From Date!",! G EN - 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) - I FBDOD]"",FBTODT>FBDOD W !!,*7,?5,"Date of Discharge must not be earlier than the Authorization To Date!",! G EN - S DIR(0)="162.4,5",DIR("A")="ADMITTING AUTHORITY" D ^DIR K DIR - G END:$D(DIRUT) S FBADMIT=+Y - S DIR(0)="162.4,6" D ^DIR K DIR - G END:$D(DIRUT) S FBEST=+Y -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 - ; -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 -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 - S DIC="^FB7078(",DIC(0)="LQ",DLAYGO=162.4,X=""""_FB7078_"""" D ^DIC G:Y<0 PROB S (DA,FBAA78)=+Y - S DIE="^FBAA(162.2,",DA=FBDA,DR="16////^S X=FBAA78" D ^DIE K DIE,DIC,DA,DR -SET78 S DIE="^FB7078(",DA=FBAA78,DR="[FBCH ENTER 7078]" D ^DIE K DIC,DIE,DR,DA - D ^FBCH780 I $G(FBOUT) W !!,*7,"...deleting 7078." D DEL G END - I +Y=0 W !!,*7,Y,!,"...deleting 7078. Use 'Set-up a 7078' after adjusting 1358.",! D DEL G END - K DIE,DIC,DA - I $G(FBVET) S:'$G(DFN) DFN=FBVET D PTF^FBCH780 - G SHOW:FBTODT="" -AUTH D HOME^%ZIS - 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:"") - S FBVEN=$P(FBVEN,";") - 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 - S:'$D(^FBAAA(FBVET,1,0)) ^(0)="^161.01D^^" - K DE,DQ,DR,DIE,DLAYGO -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 -FBPUR S FBTYPE=6,DIR(0)="161.01,.07" D ^DIR K DIR S FBPUR=+Y - G END:$D(DTOUT),END:$D(DUOUT) -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 - ;file entry in authorization multiple of file 161 - 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 - S FB78=FBAA78_";FB7078(" - ;FB*3.5*103 ;added FBRP - 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" - S:$G(FBRP)]"" DR=DR_";104////^S X=FBRP" - S DR=DR_";.095////^S X=1" - 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""" - D ^DIE K DIE,DR - S (DIC,DIE)="^FB7078(",DA=FBAA78,DR="9///^S X=""C"";12///^S X=""@""" D ^DIE K DR,DIE,DA,X -SHOW W !! S DA=FBAA78,DR="0;1",DIC="^FB7078(" D EN^DIQ - ; - ;FB*3.5*103 ;added FBRP -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 - K FBDCHG,FBPUR,FBPDIS,FBADMIT,FBDXS,A,D0,D1,X1,DIRUT,DTOUT,DUOUT,FBDOA,FBDOD,FBPOP,FBZZ,ZZZ,PRCSCPAN,FBRP - Q -PROB W !!,"The reference number did not get set up with the",!,"IFCAP software. Contact your package coordinator." G END -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 - ; -OUTP ;ENTRY TO DISPLAY A 7078 - ;FB*3.5*103 ; Display the 0 node fields with computed REFERRING PROVIDER NPI, then 1 node fields - 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",DIQ(0)="C" W !! D EN^DIQ K DIQ(0) - S DA=FBDA,DR="1" D EN^DIQ - I $$DISCH^FBCH780(FBDA)]"" W ?2,"DISCHARGE TYPE: ",$$DISCH^FBCH780(FBDA),! - G OUTP - ; -REFNPI(IEN200,IEN162P4,CHKAUTH) ;FB*3.5*103 - ; a new function that returns the REFERRING PROVIDER NPI if it is Active and the provider has authorized use of the NPI - ; If is used in both a Fileman function and in other FB routines. - ; - ; Input - ; IEN200 - IEN to file 200 if known - ; IEN162P4 (optional) - IEN to File 162.4 (if ref prov is not known) - ; CHKAUTH (optional) - Flag on whether to Chek Authorization in file 200 - ; - ; Output - ; A valid/active NPI if one can be determined. Otherwise, nada. - ; - ; If neither IEN is passed in, there is no NPI coming out - I $G(IEN200)<1,$G(IEN162P4)<1 Q "" - ; - ; If there is no referrring provider IEN passed in, try getting it from the IEN from 162.4 (VA FORM 10-7078) - ; return nothing if you can't - I $G(IEN200)<1 S IEN200=$$GET1^DIQ(162.4,IEN162P4_",",15,"I") Q:$G(IEN200)<1 "" - ; - ; Now that we have an IEN to 200 see if we need authorization and have to display/print NPI - ; If the return value is less than 1, then we don't have permission or it was not a valid IEN. - ; IA#5070 - I $G(CHKAUTH) Q:+$$GETRLNPI^XUSNPI(IEN200)<1 "" - ; - ; Go get the NPI for this IEN - N NPI S NPI=$$NPI^XUSNPI("Individual_ID",IEN200) - ; - ; Make sure it is a valid/Active NPI - I +NPI<1!($P(NPI,U,3)="Inactive") Q "" - Q +NPI - ; -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 +FBCH78 ;AISC/DMK-SETS UP 7078/AUTHORIZATION FOR CONTRACT HOSPITAL ;08/07/02 + ;;3.5;FEE BASIS;**43**;JAN 30, 1995 + ;;Per VHA Directive 10-93-142, this routine should not be modified. + 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)) + 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 +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 + W !! S %DT="APEX",%DT("A")="AUTHORIZATION TO DATE: " D ^%DT K %DT G END:X="^" S FBTODT=$S(X="":"",1:Y) + I FBTODT]"",FBFRDT>FBTODT W !!,*7,?5,"Authorization To Date must be after Authorization From Date!",! G EN + 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) + I FBDOD]"",FBTODT>FBDOD W !!,*7,?5,"Date of Discharge must not be earlier than the Authorization To Date!",! G EN + S DIR(0)="162.4,5",DIR("A")="ADMITTING AUTHORITY" D ^DIR K DIR + G END:$D(DIRUT) S FBADMIT=+Y + S DIR(0)="162.4,6" D ^DIR K DIR + G END:$D(DIRUT) S FBEST=+Y +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 + ; +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 +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 + S DIC="^FB7078(",DIC(0)="LQ",DLAYGO=162.4,X=""""_FB7078_"""" D ^DIC G:Y<0 PROB S (DA,FBAA78)=+Y + S DIE="^FBAA(162.2,",DA=FBDA,DR="16////^S X=FBAA78" D ^DIE K DIE,DIC,DA,DR +SET78 S DIE="^FB7078(",DA=FBAA78,DR="[FBCH ENTER 7078]" D ^DIE K DIC,DIE,DR,DA + D ^FBCH780 I $G(FBOUT) W !!,*7,"...deleting 7078." D DEL G END + I +Y=0 W !!,*7,Y,!,"...deleting 7078. Use 'Set-up a 7078' after adjusting 1358.",! D DEL G END + K DIE,DIC,DA + I $G(FBVET) S:'$G(DFN) DFN=FBVET D PTF^FBCH780 + G SHOW:FBTODT="" +AUTH D HOME^%ZIS + 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:"") + S FBVEN=$P(FBVEN,";") + 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 + S:'$D(^FBAAA(FBVET,1,0)) ^(0)="^161.01D^^" + K DE,DQ,DR,DIE,DLAYGO +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 +FBPUR S FBTYPE=6,DIR(0)="161.01,.07" D ^DIR K DIR S FBPUR=+Y + G END:$D(DTOUT),END:$D(DUOUT) +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 + ;file entry in authorization multiple of file 161 + 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 + S FB78=FBAA78_";FB7078(" + 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" + 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""" + D ^DIE K DIE,DR + S (DIC,DIE)="^FB7078(",DA=FBAA78,DR="9///^S X=""C"";12///^S X=""@""" D ^DIE K DIE,DIE,DA,X +SHOW W !! S DA=FBAA78,DR="0;1",DIC="^FB7078(" D EN^DIQ + ; +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 + K FBDCHG,FBPUR,FBPDIS,FBADMIT,FBDXS,A,D0,D1,X1,DIRUT,DTOUT,DUOUT,FBDOA,FBDOD,FBPOP,FBZZ,ZZZ,PRCSCPAN + Q +PROB W !!,"The reference number did not get set up with the",!,"IFCAP software. Contact your package coordinator." G END +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 + ; +OUTP ;ENTRY TO DISPLAY A 7078 + 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 + I $$DISCH^FBCH780(FBDA)]"" W ?2,"DISCHARGE TYPE: ",$$DISCH^FBCH780(FBDA),! + G OUTP +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 Index: WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBCH78A.m =================================================================== --- WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBCH78A.m (revision 613) +++ WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBCH78A.m (revision 623) @@ -1,33 +1,28 @@ -FBCH78A ;AISC/DMK-PRINT 7078 CONTINUED FROM FBCHP78 ;06FEB89 - ;;3.5;FEE BASIS;**103**;JAN 30, 1995;Build 19 - ;;Per VHA Directive 2004-038, this routine should not be modified. -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,! - Q -BOT W !,"SPECIAL PROVISIONS: Acceptance of this authorization to render service is governed by the following:",!! - 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 " - W "PERTAINING TO THE VA",!,?3,"AUTHORIZED TREATMENT OR SERVICES OF THIS VETERAN.",! - 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.",! - W !,"3. Payment by the VA is payment in full for authorized services rendered.",! - 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 ",! - W ?3,"office with a brief explanation.",! - W !,"5. A copy of the Operative Report will be forwarded to the Authorizing station within one week following any major",!,?3,"surgery.",! - 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.",! - W !,"7. When submitting claims for payment you must include the NPI and Taxonomy Code of the rendering practitioner," - W !,?3,"and the NPI and Taxonomy Code of your organization. If, under the HIPAA NPI Final Rule" - W !,?3,"[http://www.cms.hhs.gov/NationalProvIdentStand], your organization is an ""atypical"" provider furnishing services such" - W !,?3,"as taxi, home and vehicle modifications, insect control, habilitation, and respite services and is therefore" - W !,?3,"ineligible for an NPI, it is important that you indicate ""Ineligible for NPI"" on your claim form.",! - W UL,!,?16,"All questions relating to this authorization should be referred to the issuing VA Office",!,UL,!,"VA Form 10-7078" Q - ; -FISCAL ;SETS THE FISCAL SYMBOL BLOCK FOR 7078 - S PRC("SITE")=FB("SITE"),PRCS("X")=PRC("SITE")_"-"_$P($P(FB(0),"^"),"."),PRCS("TYPE")="FB" D EN1^PRCS58 - S FB("SYM")=$P(Y,"^",4)_" "_$P(FB(0),"^")_" FCP "_$P(Y,U,3) K PRC("SITE"),PRCSI,Y Q - ; -CONT(X,Y) ;get contract for CNH authorization - ;X=IEN of vendor - ;Y=from date of authorization - I $S('$G(X):1,'$G(Y):1,1:0) Q "" - I '$O(^FBAA(161.21,"ACR",X,-Y+.9)) Q "" - N Z - S Z=$P(^FBAA(161.21,+$O(^(+$O(^FBAA(161.21,"ACR",X,-Y+.9)),0)),0),U,1,3) - Q $S($P(Z,U,3)>Y:$P(Z,U),1:"") +FBCH78A ;AISC/DMK-PRINT 7078 CONTINUED FROM FBCHP78 ;06FEB89 + ;;3.5;FEE BASIS;;JAN 30, 1995 + ;;Per VHA Directive 10-93-142, this routine should not be modified. +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,! + Q +BOT W !,"SPECIAL PROVISIONS: Acceptance of this authorization to render service is governed by the following:",!! + 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 " + W "PERTAINING TO THE VA",!,?3,"AUTHORIZED TREATMENT OR SERVICES OF THIS VETERAN.",! + 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.",! + W !,"3. Payment by the VA is payment in full for authorized services rendered.",! + 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 ",! + W ?3,"office with a brief explanation.",! + W !,"5. A copy of the Operative Report will be forwarded to the Authorizing station within one week following any major",!,?3,"surgery.",! + 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.",! + W UL,!,?16,"All questions relating to this authorization should be referred to the issuing VA Office",!,UL,!,"VA Form 10-7078" Q + ; +FISCAL ;SETS THE FISCAL SYMBOL BLOCK FOR 7078 + S PRC("SITE")=FB("SITE"),PRCS("X")=PRC("SITE")_"-"_$P($P(FB(0),"^"),"."),PRCS("TYPE")="FB" D EN1^PRCS58 + S FB("SYM")=$P(Y,"^",4)_" "_$P(FB(0),"^")_" FCP "_$P(Y,U,3) K PRC("SITE"),PRCSI,Y Q + ; +CONT(X,Y) ;get contract for CNH authorization + ;X=IEN of vendor + ;Y=from date of authorization + I $S('$G(X):1,'$G(Y):1,1:0) Q "" + I '$O(^FBAA(161.21,"ACR",X,-Y+.9)) Q "" + N Z + S Z=$P(^FBAA(161.21,+$O(^(+$O(^FBAA(161.21,"ACR",X,-Y+.9)),0)),0),U,1,3) + Q $S($P(Z,U,3)>Y:$P(Z,U),1:"") Index: WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBCHP78.m =================================================================== --- WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBCHP78.m (revision 613) +++ WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBCHP78.m (revision 623) @@ -1,58 +1,55 @@ -FBCHP78 ;AISC/DMK-GENERATE 7078 ;7/NOV/2006 - ;;3.5;FEE BASIS;**12,23,52,101,103**;JAN 30, 1995;Build 19 - ;;Per VHA Directive 2004-038, this routine should not be modified. - I '$D(^FBAA(161.4,1,0)) W !,"Site Parameters must be entered prior",!," to using this option." Q -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 - S DA=FB7078,DIC="^FB7078(",DR=0 D EN^DIQ -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 - D SITEP^FBAAUTL S FBO=$S($D(FBSITE(1)):$P(FBSITE(1),"^",7),1:""),FBNUM=$S($D(FBSITE(1)):$P(FBSITE(1),"^",5),1:"") - S FBT=$S($D(FBSITE(1)):$P(FBSITE(1),"^",8),1:"") - D FBO G END:$D(DIRUT) - S PRCF("X")="S" D ^PRCFSITE S PRC("SITE")=$S($D(PRC("SITE")):PRC("SITE"),1:"") I PRC("SITE")="" W ! G GET78 - S FB("SITE")=PRC("SITE") -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 - ; -START S FB(0)=^FB7078(FB7078,0) S:$E(IOST,1,2)'["C-" FBPG=1 F FBM=1:1:FBNUM D 7078 -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 - D CLOSE^FBAAUTL Q - ; -7078 U IO S UL="",$P(UL,"-",120)="-",L="|" D HED^FBCH78A - S DFN=$P(^FB7078(FB7078,0),"^",3) G END:'$D(DFN)#2!('$D(^DPT(+DFN,0))) - N FBNAME - S FBNAME("FILE")=2,FBNAME("IENS")=DFN_",",FBNAME("FIELD")=.01 - S FBNAME=$$NAMEFMT^XLFNAME(.FBNAME,"F","C") - S VAPA("P")="" D SITEP^FBAAUTL,6^VADPT - N FBCONFAD S FBCONFAD=$$ACTIVECC^FBAACO0() I FBCONFAD,$L($G(VAPA(16))) D - . 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) - F FBNM=1:1:7 S FBNM(FBNM)=$P(FBSITE(0),"^",FBNM) - S FBNM(5)=$S($D(^DIC(5,FBNM(5))):$P(^(FBNM(5),0),"^",2),1:"") - 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:"") - F I=3:1:6,14 S FBV(I)=$S($D(^FBAAV(FBV(0),0)):$P(^(0),"^",I),1:"") - I FBV(5)]"" S FBV(5)=$S($D(^DIC(5,FBV(5),0)):$P(^(0),"^",2),1:"") - 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 - 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:"") - 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",! - I FBNM(3)]"" W ?5,FBNM(4)_", "_FBNM(5)_" "_FBNM(6) - 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) - W ?66,L,?68,$S(FBCONFAD:VAPA(15),1:VAPA(3)),!?5,FBV(4)_", "_FBV(5)_" "_FBV(6) - 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) - 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),! - ; next few lines contain changes that display/print the referring provider data FB*3.5*103 - W "Name of VA Referring Provider",?66,L,"From",?93,L,"To",! - W ?5,$$GET1^DIQ(162.4,FB7078_",",15),?50,"NPI: ",$$REFNPI^FBCH78("",FB7078,1) - 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",! - W ?12,"(See Special Provisions below.)",?104,L,"$",! - S DIWL=1,DIWF="WC103" K ^UTILITY($J,"W") - 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 - D ^DIWW:$D(FBXX) K FBXX - D FISCAL^FBCH78A - 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,"$" - K X2 S X=$P(FB(0),"^",7),X3=$L(+X)+2 D COMMA^%DTC K X3 W X,!,UL,! - W "11. Fiscal Symbols",?66,L,"12. Authorized by (Name and Title)",!,?5,FB("SYM"),?66,L,?68,FBO," ",FBT,!,UL - D BOT^FBCH78A - Q -DATE S Y=$$FMTE^XLFDT(Y) Q - ; -FBO S DIR(0)="F^3:45",DIR("A")="Approving Official for 7078",DIR("B")=FBO,DIR("?")="Enter 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 -FBT S DIR(0)="F^3:45",DIR("A")="Title of Approving Official",DIR("B")=FBT,DIR("?")="Enter 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 -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 +FBCHP78 ;AISC/DMK-GENERATE 7078 ;7/NOV/2006 + ;;3.5;FEE BASIS;**12,23,52,101**;JAN 30, 1995;Build 2 + ;;Per VHA Directive 2004-038, this routine should not be modified. + I '$D(^FBAA(161.4,1,0)) W !,"Site Parameters must be entered prior",!," to using this option." Q +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 + S DA=FB7078,DIC="^FB7078(",DR=0 D EN^DIQ +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 + D SITEP^FBAAUTL S FBO=$S($D(FBSITE(1)):$P(FBSITE(1),"^",7),1:""),FBNUM=$S($D(FBSITE(1)):$P(FBSITE(1),"^",5),1:"") + S FBT=$S($D(FBSITE(1)):$P(FBSITE(1),"^",8),1:"") + D FBO G END:$D(DIRUT) + S PRCF("X")="S" D ^PRCFSITE S PRC("SITE")=$S($D(PRC("SITE")):PRC("SITE"),1:"") I PRC("SITE")="" W ! G GET78 + S FB("SITE")=PRC("SITE") +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 + ; +START S FB(0)=^FB7078(FB7078,0) S:$E(IOST,1,2)'["C-" FBPG=1 F FBM=1:1:FBNUM D 7078 +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 + D CLOSE^FBAAUTL Q + ; +7078 U IO S UL="",$P(UL,"-",120)="-",L="|" D HED^FBCH78A + S DFN=$P(^FB7078(FB7078,0),"^",3) G END:'$D(DFN)#2!('$D(^DPT(+DFN,0))) + N FBNAME + S FBNAME("FILE")=2,FBNAME("IENS")=DFN_",",FBNAME("FIELD")=.01 + S FBNAME=$$NAMEFMT^XLFNAME(.FBNAME,"F","C") + S VAPA("P")="" D SITEP^FBAAUTL,6^VADPT + N FBCONFAD S FBCONFAD=$$ACTIVECC^FBAACO0() I FBCONFAD,$L($G(VAPA(16))) D + . 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) + F FBNM=1:1:7 S FBNM(FBNM)=$P(FBSITE(0),"^",FBNM) + S FBNM(5)=$S($D(^DIC(5,FBNM(5))):$P(^(FBNM(5),0),"^",2),1:"") + 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:"") + F I=3:1:6,14 S FBV(I)=$S($D(^FBAAV(FBV(0),0)):$P(^(0),"^",I),1:"") + I FBV(5)]"" S FBV(5)=$S($D(^DIC(5,FBV(5),0)):$P(^(0),"^",2),1:"") + 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 + 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:"") + 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",! + I FBNM(3)]"" W ?5,FBNM(4)_", "_FBNM(5)_" "_FBNM(6) + 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) + W ?66,L,?68,$S(FBCONFAD:VAPA(15),1:VAPA(3)),!?5,FBV(4)_", "_FBV(5)_" "_FBV(6) + 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) + 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),! + 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",! + W ?12,"(See Special Provisions below.)",?104,L,"$",! + S DIWL=1,DIWF="WC103" K ^UTILITY($J,"W") + 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 + D ^DIWW:$D(FBXX) K FBXX + D FISCAL^FBCH78A + 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,"$" + K X2 S X=$P(FB(0),"^",7),X3=$L(+X)+2 D COMMA^%DTC K X3 W X,!,UL,! + W "11. Fiscal Symbols",?66,L,"12. Authorized by (Name and Title)",!,?5,FB("SYM"),?66,L,?68,FBO," ",FBT,!,UL + D BOT^FBCH78A + Q +DATE S Y=$$FMTE^XLFDT(Y) Q + ; +FBO S DIR(0)="F^3:45",DIR("A")="Approving Official for 7078",DIR("B")=FBO,DIR("?")="Enter 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 +FBT S DIR(0)="F^3:45",DIR("A")="Title of Approving Official",DIR("B")=FBT,DIR("?")="Enter 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 +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 Index: WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBCHREQ1.m =================================================================== --- WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBCHREQ1.m (revision 613) +++ WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBCHREQ1.m (revision 623) @@ -1,31 +1,30 @@ -FBCHREQ1 ;AISC/DMK-FEE NOTIFICATION CONT ;31AUG90 - ;;3.5;FEE BASIS;**103**;JAN 30, 1995;Build 19 - ;;Per VHA Directive 2004-038, this routine should not be modified. -VENDOR ;ASK VENDOR FOR NOTIFICATION - 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 -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 -END K DIC,DIE,DLAYGO - Q -TIMCK ;72 hour time check called from FBAA ENTER REQUEST template - S X1=$P(^FBAA(162.2,DA,0),"^",1),X=$P(^(0),"^",19),HY=Y,FBSW="" - 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 -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 - S Y=HY Q -HELP W !,"Entering an '^' is not allowed. Please answer 'Yes' or 'No'." G SURE -EN I $D(DA),DA S FBDA(0)=DA,DIE="^FBAA(162.2,",DR=".01////@" D ^DIE - 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 - K DIC,DIE,DIK,DA,X,FBDA,DR,DLAYGO,FBDATE,FBLG,FBN,FBUP,FBVT,VA D END^FBCHREQ - Q -EDIT ;EDIT A REQUEST THAT'S NOT COMPLETE - 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) - ; fb*3.5*103 add REFERRING PROVIDER (162.2,17) to DR string - S DIE="^FBAA(162.2,",DR="1;2;3.5;S:X=FBDOA!(X or = date of admission. - S FBDOA=$P(^FBAA(162.2,DA,0),"^",19) I $G(FBDOA),X4320 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 + S Y=HY Q +HELP W !,"Entering an '^' is not allowed. Please answer 'Yes' or 'No'." G SURE +EN I $D(DA),DA S FBDA(0)=DA,DIE="^FBAA(162.2,",DR=".01////@" D ^DIE + 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 + K DIC,DIE,DIK,DA,X,FBDA,DR,DLAYGO,FBDATE,FBLG,FBN,FBUP,FBVT,VA D END^FBCHREQ + Q +EDIT ;EDIT A REQUEST THAT'S NOT COMPLETE + 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) + S DIE="^FBAA(162.2,",DR="1;2;3.5;S:X=FBDOA!(X or = date of admission. + S FBDOA=$P(^FBAA(162.2,DA,0),"^",19) I $G(FBDOA),X^(""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 Q ; -20 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=20 D X20 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 -X20 I $G(X) W !,"REFERRING PROVIDER NPI: ",$$REFNPI^FBCH78(X) +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 +X21 S:$$EXTPV^FBAAUTL5(X)'=55 Y="@5" Q -21 S DQ=22 ;@4 -22 S DW="0;7",DV="R*P161.82'",DU="",DLB="PURPOSE OF VISIT CODE",DIFLD=.07 - S DU="FBAA(161.82," - G RE -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 +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 +X22 S:$P($$GETSTAT^DGMSTAPI(DA(1)),U,2)="Y" Y="@5" Q - ; 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 -X23 S:$$EXTPV^FBAAUTL5(X)'=55 Y="@5" +X23 S DIE("NO^")="" Q 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 -X24 S:$P($$GETSTAT^DGMSTAPI(DA(1)),U,2)="Y" Y="@5" +X24 W !,$C(7),"MST POV can't be selected because veteran's MST status is not YES." Q 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 -X25 S DIE("NO^")="" +X25 S Y="@4" Q -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 -X26 W !,$C(7),"MST POV can't be selected because veteran's MST status is not YES." - Q -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 -X27 S Y="@4" - Q -28 S DQ=29 ;@5 -29 S DW="0;18",DV="S",DU="",DLB="PATIENT TYPE CODE",DIFLD=.065 - S DU="00:SURGICAL;10:MEDICAL;60:HOME NURSING SERVICE;85:PSYCHIATRIC-CONTRACT;86:PSYCHIATRIC;95:NEUROLOGICAL-CONTRACT;96:NEUROLOGICAL;" - G RE -X29 Q -30 S DW="0;13",DV="R*S",DU="",DLB="TREATMENT TYPE CODE",DIFLD=.095 - S DE(DW)="C30^FBCTAU1" - S DU="1:SHORT TERM FEE STATUS;2:HOME NURSING SERVICES;3:I.D. CARD STATUS;4:STATE HOME;" - G RE -C30 G C30S:$D(DE(30))[0 K DB - S X=DE(30),DIC=DIE - ; -C30S S X="" G:DG(DQ)=X C30F1 K DB - D ^FBCTAU2 -C30F1 Q -X30 Q -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 -X31 S FBAATT=X - Q -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 -X32 S FBAALT=$S(X=2:"Y",X=3:"Y",1:"") - Q -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 -X33 K DIE("NO^") - Q -34 D:$D(DG)>9 F^DIE17 G ^FBCTAU3 +26 S DQ=27 ;@5 +27 D:$D(DG)>9 F^DIE17 G ^FBCTAU2 Index: WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBCTAU2.m =================================================================== --- WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBCTAU2.m (revision 613) +++ WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBCTAU2.m (revision 623) @@ -1,3 +1,213 @@ -FBCTAU2 ; ;11/08/09 +FBCTAU2 ; ;06/28/03 + D DE G BEGIN +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,""))="" + 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)=% + I $D(^(3)) S %Z=^(3) S %=$P(%Z,U,1) S:%]"" DE(8)=% S %=$P(%Z,U,2) S:%]"" DE(10)=% + I $D(^(100)) S %Z=^(100) S %=$P(%Z,U,1) S:%]"" DE(17)=% + I $D(^("C")) S %Z=^("C") S %=$P(%Z,U,1) S:%]"" DE(21)=%,DE(24)=% + K %Z Q + ; +W W !?DL+DL-2,DLB_": " + Q +O D W W Y W:$X>45 !?9 + I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2 + W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W " (No Editing)" Q +TR R X:DTIME E S (DTOUT,X)=U W $C(7) + Q +A K DQ(DQ) S DQ=DQ+1 +B G @DQ +RE G PR:$D(DE(DQ)) D W,TR +N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A +RD G QS:X?."?" I X["^" D D G ^DIE17 + I X="@" D D G Z^DIE2 + I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W " "_X +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 + K DDER G X +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 + G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z + I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X +V D @("X"_DQ) K YS +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 +X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17 + S X="?BAD" +QS S DZ=X D D,QQ^DIEQ G B +D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q +Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N +PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP +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 + 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 + X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=% +RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17 +I I DV'["I",DV'["#" G RD + D E^DIE0 G RD:$D(X),PR + Q +SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1 + I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1 + D ^DIR I 'DDER S %=Y(0),X=Y + Q +SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ)) + I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")="" + E K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/") + Q +NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G QS +KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") +BEGIN S DNM="FBCTAU2",DQ=1 +1 S DW="0;18",DV="S",DU="",DLB="PATIENT TYPE CODE",DIFLD=.065 + S DU="00:SURGICAL;10:MEDICAL;60:HOME NURSING SERVICE;85:PSYCHIATRIC-CONTRACT;86:PSYCHIATRIC;95:NEUROLOGICAL-CONTRACT;96:NEUROLOGICAL;" + G RE +X1 Q +2 S DW="0;13",DV="R*S",DU="",DLB="TREATMENT TYPE CODE",DIFLD=.095 + S DE(DW)="C2^FBCTAU2" + S DU="1:SHORT TERM FEE STATUS;2:HOME NURSING SERVICES;3:I.D. CARD STATUS;4:STATE HOME;" + G RE +C2 G C2S:$D(DE(2))[0 K DB + S X=DE(2),DIC=DIE + ; +C2S S X="" G:DG(DQ)=X C2F1 K DB S X=DG(DQ),DIC=DIE D:'$D(DIU(0)) EVENT^IVMPLOG(DA(1)) +C2F1 Q +X2 Q +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 +X3 S FBAATT=X + Q +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 +X4 S FBAALT=$S(X=2:"Y",X=3:"Y",1:"") + Q +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 +X5 K DIE("NO^") + Q +6 D:$D(DG)>9 F^DIE17,DE S DQ=6,DW="0;8",DV="F",DU="",DLB="DX LINE 1",DIFLD=.08 + G RE +X6 K:$L(X)>60!($L(X)<3) X + I $D(X),X'?.ANP K X + Q + ; +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 +X7 S:X="" Y=.021 + Q +8 S DW="3;1",DV="F",DU="",DLB="DX LINE 2",DIFLD=.085 + G RE +X8 K:$L(X)>60!($L(X)<2) X + I $D(X),X'?.ANP K X + Q + ; +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 +X9 S:X="" Y=.021 + Q +10 S DW="3;2",DV="F",DU="",DLB="DX LINE 3",DIFLD=.086 + G RE +X10 K:$L(X)>60!($L(X)<2) X + I $D(X),X'?.ANP K X + Q + ; +11 S D=0 K DE(1) ;.021 + S Y="AUTHORIZATION REMARKS^W^^0;1^Q",DG="2",DC="^161.06" D DIEN^DIWE K DE(1) G A + ; +12 S DW="0;14",DV="S",DU="",DLB="TYPE OF CARE",DIFLD=2 + S DU="1:C&P;2:OPT NSC;3:OPT SC;" + G RE +X12 Q +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 +X13 S:'$D(FBAAASKV) FBAAASKV="N" + Q +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 +X14 S:FBAAASKV'="y" Y=100 + Q +15 S DW="0;4",DV="P161.2",DU="",DLB="VENDOR",DIFLD=.04 + S DE(DW)="C15^FBCTAU2" + S DU="FBAAV(" + G RE +C15 G C15S:$D(DE(15))[0 K DB + S X=DE(15),DIC=DIE + K ^FBAAA("ACV",$E(X,1,30),DA(1),DA) +C15S S X="" G:DG(DQ)=X C15F1 K DB + S X=DG(DQ),DIC=DIE + S ^FBAAA("ACV",$E(X,1,30),DA(1),DA)="" +C15F1 Q +X15 Q +16 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=16 G A +17 D:$D(DG)>9 F^DIE17,DE S DQ=17,DW="100;1",DV="P200'",DU="",DLB="CLERK",DIFLD=100 + S DU="VA(200," + S X=DUZ + S Y=X + 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) + G RD:X="@",Z +X17 Q +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 +X18 W !! + Q +19 S DW="0;19",DV="FXO",DU="",DLB="ACCIDENT RELATED (Y/N)",DIFLD=.096 + S DQ(19,2)="S Y(0)=Y D OUTYN^FBAAUTL3" + S DE(DW)="C19^FBCTAU2" + G RE +C19 G C19S:$D(DE(19))[0 K DB + S X=DE(19),DIC=DIE + K ^FBAAA("AA",X,$P(^FBAAA(DA(1),1,DA,0),U,1),DA(1),DA) +C19S S X="" G:DG(DQ)=X C19F1 K DB + S X=DG(DQ),DIC=DIE + S ^FBAAA("AA",X,$P(^FBAAA(DA(1),1,DA,0),U,1),DA(1),DA)="" +C19F1 Q +X19 I $D(X) D YN^FBAAUTL3 + I $D(X),X'?.ANP K X + Q + ; +20 D:$D(DG)>9 F^DIE17,DE S DQ=20,DW="0;20",DV="RFXO",DU="",DLB="POTENTIAL COST RECOVERY CASE",DIFLD=.097 + S DQ(20,2)="S Y(0)=Y D OUTYN^FBAAUTL3" + S DE(DW)="C20^FBCTAU2" + S X="NO" + S Y=X + G Y +C20 G C20S:$D(DE(20))[0 K DB + S X=DE(20),DIC=DIE + K ^FBAAA("AC",X,$P(^FBAAA(DA(1),1,DA,0),U,1),DA(1),DA) + S X=DE(20),DIC=DIE + K:$P(^FBAAA(DA(1),1,DA,0),U) ^FBAAA("AIC",DA(1),-($P(^FBAAA(DA(1),1,DA,0),U)),X,DA) +C20S S X="" G:DG(DQ)=X C20F1 K DB + S X=DG(DQ),DIC=DIE + S ^FBAAA("AC",X,$P(^FBAAA(DA(1),1,DA,0),U,1),DA(1),DA)="" + S X=DG(DQ),DIC=DIE + S:$P(^FBAAA(DA(1),1,DA,0),U) ^FBAAA("AIC",DA(1),-($P(^FBAAA(DA(1),1,DA,0),U)),X,DA)="" +C20F1 Q +X20 I $D(X) D YN^FBAAUTL3 + I $D(X),X'?.ANP K X + Q + ; +21 D:$D(DG)>9 F^DIE17,DE S DQ=21,DW="C;1",DV="FX",DU="",DLB="PRINT AUTHORIZATION (Y/N)",DIFLD=1 + S DE(DW)="C21^FBCTAU2" + S X="YES" + S Y=X + G Y +C21 G C21S:$D(DE(21))[0 K DB + S X=DE(21),DIC=DIE + D KILL^FBAAUTL2 +C21S S X="" G:DG(DQ)=X C21F1 K DB + S X=DG(DQ),DIC=DIE + D ADD^FBAAUTL2 +C21F1 Q +X21 I $D(X) D YN^FBAAUTL3 + I $D(X),X'?.ANP K X + Q + ; +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 +X22 S FBAAP79=$S(X["Y":"Y",1:"") + Q +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 +X23 I X["Y" S Y="" + Q +24 D:$D(DG)>9 F^DIE17,DE S DQ=24,DW="C;1",DV="FX",DU="",DLB="PRINT AUTHORIZATION (Y/N)",DIFLD=1 + S DE(DW)="C24^FBCTAU2" + S X="@" + S Y=X + 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) + G RD +C24 G C24S:$D(DE(24))[0 K DB + D ^FBCTAU3 +C24S S X="" G:DG(DQ)=X C24F1 K DB + D ^FBCTAU4 +C24F1 Q +X24 I $D(X) D YN^FBAAUTL3 + I $D(X),X'?.ANP K X + Q + ; +25 G 1^DIE17 Index: WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBCTAU3.m =================================================================== --- WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBCTAU3.m (revision 613) +++ WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBCTAU3.m (revision 623) @@ -1,190 +1,3 @@ -FBCTAU3 ; ;11/08/09 - D DE G BEGIN -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,""))="" - 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)=% - I $D(^(3)) S %Z=^(3) S %=$P(%Z,U,1) S:%]"" DE(3)=% S %=$P(%Z,U,2) S:%]"" DE(5)=% - I $D(^(100)) S %Z=^(100) S %=$P(%Z,U,1) S:%]"" DE(12)=% - I $D(^("C")) S %Z=^("C") S %=$P(%Z,U,1) S:%]"" DE(16)=%,DE(19)=% - K %Z Q - ; -W W !?DL+DL-2,DLB_": " - Q -O D W W Y W:$X>45 !?9 - I $L(Y)>19,'DV,DV'["I",(DV["F"!(DV["K")) G RW^DIR2 - W:Y]"" "// " I 'DV,DV["I",$D(DE(DQ))#2 S X="" W " (No Editing)" Q -TR R X:DTIME E S (DTOUT,X)=U W $C(7) - Q -A K DQ(DQ) S DQ=DQ+1 -B G @DQ -RE G PR:$D(DE(DQ)) D W,TR -N I X="" G NKEY:$D(^DD("KEY","F",DP,DIFLD)),A:DV'["R",X:'DV,X:D'>0,A -RD G QS:X?."?" I X["^" D D G ^DIE17 - I X="@" D D G Z^DIE2 - I X=" ",DV["d",DV'["P",$D(^DISV(DUZ,"DIE",DLB)) S X=^(DLB) I DV'["D",DV'["S" W " "_X -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 - K DDER G X -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 - G V:DV'["N" D D I $L($P(X,"."))>24 K X G Z - I $P(DQ(DQ),U,5)'["$",X?.1"-".N.1".".N,$P(DQ(DQ),U,5,99)["+X'=X" S X=+X -V D @("X"_DQ) K YS -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 -X W:'$D(ZTQUEUED) $C(7),"??" I $D(DB(DQ)) G Z^DIE17 - S X="?BAD" -QS S DZ=X D D,QQ^DIEQ G B -D S D=DIFLD,DQ(DQ)=DLB_U_DV_U_DU_U_DW_U_$P($T(@("X"_DQ))," ",2,99) Q -Y I '$D(DE(DQ)) D O G RD:"@"'[X,A:DV'["R"&(X="@"),X:X="@" S X=Y G N -PR S DG=DV,Y=DE(DQ),X=DU I $D(DQ(DQ,2)) X DQ(DQ,2) G RP -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 - 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 - X:DG["D" ^DD("DD") I DG["S" S %=$P($P(";"_X,";"_Y_":",2),";") S:%]"" Y=% -RP D O I X="" S X=DE(DQ) G A:'DV,A:DC<2,N^DIE17 -I I DV'["I",DV'["#" G RD - D E^DIE0 G RD:$D(X),PR - Q -SET N DIR S DIR(0)="SV"_$E("o",$D(DB(DQ)))_U_DU,DIR("V")=1 - I $D(DB(DQ)),'$D(DIQUIET) N DIQUIET S DIQUIET=1 - D ^DIR I 'DDER S %=Y(0),X=Y - Q -SAVEVALS S @DIEZTMP@("V",DP,DIIENS,DIFLD,"O")=$G(DE(DQ)) S:$D(^("F"))[0 ^("F")=$G(DE(DQ)) - I $D(DE(DW,"4/")) S @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/")="" - E K @DIEZTMP@("V",DP,DIIENS,DIFLD,"4/") - Q -NKEY W:'$D(ZTQUEUED) "?? Required key field" S X="?BAD" G QS -KEYCHK() Q:$G(DE(DW,"KEY"))="" 1 Q @DE(DW,"KEY") -BEGIN S DNM="FBCTAU3",DQ=1 -1 D:$D(DG)>9 F^DIE17,DE S DQ=1,DW="0;8",DV="F",DU="",DLB="DX LINE 1",DIFLD=.08 - G RE -X1 K:$L(X)>60!($L(X)<3) X - I $D(X),X'?.ANP K X - Q - ; -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 -X2 S:X="" Y=.021 - Q -3 S DW="3;1",DV="F",DU="",DLB="DX LINE 2",DIFLD=.085 - G RE -X3 K:$L(X)>60!($L(X)<2) X - I $D(X),X'?.ANP K X - Q - ; -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 -X4 S:X="" Y=.021 - Q -5 S DW="3;2",DV="F",DU="",DLB="DX LINE 3",DIFLD=.086 - G RE -X5 K:$L(X)>60!($L(X)<2) X - I $D(X),X'?.ANP K X - Q - ; -6 S D=0 K DE(1) ;.021 - S Y="AUTHORIZATION REMARKS^W^^0;1^Q",DG="2",DC="^161.06" D DIEN^DIWE K DE(1) G A - ; -7 S DW="0;14",DV="S",DU="",DLB="TYPE OF CARE",DIFLD=2 - S DU="1:C&P;2:OPT NSC;3:OPT SC;" - G RE -X7 Q -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 -X8 S:'$D(FBAAASKV) FBAAASKV="N" - Q -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 -X9 S:FBAAASKV'="y" Y=100 - Q -10 S DW="0;4",DV="P161.2",DU="",DLB="VENDOR",DIFLD=.04 - S DE(DW)="C10^FBCTAU3" - S DU="FBAAV(" - G RE -C10 G C10S:$D(DE(10))[0 K DB - S X=DE(10),DIC=DIE - K ^FBAAA("ACV",$E(X,1,30),DA(1),DA) -C10S S X="" G:DG(DQ)=X C10F1 K DB - S X=DG(DQ),DIC=DIE - S ^FBAAA("ACV",$E(X,1,30),DA(1),DA)="" -C10F1 Q -X10 Q -11 D:$D(DG)>9 F^DIE17,DE S Y=U,DQ=11 G A -12 D:$D(DG)>9 F^DIE17,DE S DQ=12,DW="100;1",DV="P200'",DU="",DLB="CLERK",DIFLD=100 - S DU="VA(200," - S X=DUZ - S Y=X - 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) - G RD:X="@",Z -X12 Q -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 -X13 W !! - Q -14 S DW="0;19",DV="FXO",DU="",DLB="ACCIDENT RELATED (Y/N)",DIFLD=.096 - S DQ(14,2)="S Y(0)=Y D OUTYN^FBAAUTL3" - S DE(DW)="C14^FBCTAU3" - G RE -C14 G C14S:$D(DE(14))[0 K DB - S X=DE(14),DIC=DIE - K ^FBAAA("AA",X,$P(^FBAAA(DA(1),1,DA,0),U,1),DA(1),DA) -C14S S X="" G:DG(DQ)=X C14F1 K DB - S X=DG(DQ),DIC=DIE - S ^FBAAA("AA",X,$P(^FBAAA(DA(1),1,DA,0),U,1),DA(1),DA)="" -C14F1 Q -X14 I $D(X) D YN^FBAAUTL3 - I $D(X),X'?.ANP K X - Q - ; -15 D:$D(DG)>9 F^DIE17,DE S DQ=15,DW="0;20",DV="RFXO",DU="",DLB="POTENTIAL COST RECOVERY CASE",DIFLD=.097 - S DQ(15,2)="S Y(0)=Y D OUTYN^FBAAUTL3" - S DE(DW)="C15^FBCTAU3" - S X="NO" - S Y=X - G Y -C15 G C15S:$D(DE(15))[0 K DB - S X=DE(15),DIC=DIE - K ^FBAAA("AC",X,$P(^FBAAA(DA(1),1,DA,0),U,1),DA(1),DA) - S X=DE(15),DIC=DIE - K:$P(^FBAAA(DA(1),1,DA,0),U) ^FBAAA("AIC",DA(1),-($P(^FBAAA(DA(1),1,DA,0),U)),X,DA) -C15S S X="" G:DG(DQ)=X C15F1 K DB - S X=DG(DQ),DIC=DIE - S ^FBAAA("AC",X,$P(^FBAAA(DA(1),1,DA,0),U,1),DA(1),DA)="" - S X=DG(DQ),DIC=DIE - S:$P(^FBAAA(DA(1),1,DA,0),U) ^FBAAA("AIC",DA(1),-($P(^FBAAA(DA(1),1,DA,0),U)),X,DA)="" -C15F1 Q -X15 I $D(X) D YN^FBAAUTL3 - I $D(X),X'?.ANP K X - Q - ; -16 D:$D(DG)>9 F^DIE17,DE S DQ=16,DW="C;1",DV="FX",DU="",DLB="PRINT AUTHORIZATION (Y/N)",DIFLD=1 - S DE(DW)="C16^FBCTAU3" - S X="YES" - S Y=X - G Y -C16 G C16S:$D(DE(16))[0 K DB - S X=DE(16),DIC=DIE +FBCTAU3 ; ;06/28/03 + S X=DE(24),DIC=DIE D KILL^FBAAUTL2 -C16S S X="" G:DG(DQ)=X C16F1 K DB - S X=DG(DQ),DIC=DIE - D ADD^FBAAUTL2 -C16F1 Q -X16 I $D(X) D YN^FBAAUTL3 - I $D(X),X'?.ANP K X - Q - ; -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^DIE17 -X17 S FBAAP79=$S(X["Y":"Y",1:"") - Q -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 -X18 I X["Y" S Y="" - Q -19 D:$D(DG)>9 F^DIE17,DE S DQ=19,DW="C;1",DV="FX",DU="",DLB="PRINT AUTHORIZATION (Y/N)",DIFLD=1 - S DE(DW)="C19^FBCTAU3" - S X="@" - S Y=X - 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) - G RD -C19 G C19S:$D(DE(19))[0 K DB - S X=DE(19),DIC=DIE - D KILL^FBAAUTL2 -C19S S X="" G:DG(DQ)=X C19F1 K DB - S X=DG(DQ),DIC=DIE - D ADD^FBAAUTL2 -C19F1 Q -X19 I $D(X) D YN^FBAAUTL3 - I $D(X),X'?.ANP K X - Q - ; -20 G 1^DIE17 Index: WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBNHEAU1.m =================================================================== --- WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBNHEAU1.m (revision 613) +++ WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBNHEAU1.m (revision 623) @@ -1,19 +1,18 @@ -FBNHEAU1 ;AISC/dmk - continue FBNHEAUT cnh authorization ;4/28/93 11:04 - ;;3.5;FEE BASIS;**103**;JAN 30, 1995;Build 19 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; -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 - 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 - 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 - K FBRP - Q - ; -NOGOOD ;ERROR - W !!,"No valid Obligation Number selected" G END - ; -PROB ;ERROR - W !!,"Unable to get Obligation Sequence number from IFCAP!",!,"Check with IFCAP package coordinator!" Q - ; -PROB2 ;ERROR - W !!,"Unable to add an entry in the VA Form 7078 file. Please see Computer Staff!" Q - Q +FBNHEAU1 ;AISC/dmk - continue FBNHEAUT cnh authorization ;4/28/93 11:04 + ;;3.5;FEE BASIS;;JAN 30, 1995 + ;;Per VHA Directive 10-93-142, this routine should not be modified. + ; +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 + 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 + 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 + Q + ; +NOGOOD ;ERROR + W !!,"No valid Obligation Number selected" G END + ; +PROB ;ERROR + W !!,"Unable to get Obligation Sequence number from IFCAP!",!,"Check with IFCAP package coordinator!" Q + ; +PROB2 ;ERROR + W !!,"Unable to add an entry in the VA Form 7078 file. Please see Computer Staff!" Q + Q Index: WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBNHEAUT.m =================================================================== --- WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBNHEAUT.m (revision 613) +++ WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBNHEAUT.m (revision 623) @@ -1,58 +1,55 @@ -FBNHEAUT ;AISC/DMK,GRR-ENTER/EDIT AUTHORIZATION ;08/07/02 - ;;3.5;FEE BASIS;**43,103**;JAN 30, 1995;Build 19 - ;;Per VHA Directive 2004-038, this routine should not be modified. - 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 !! - ; - 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") - ; - W !! S DIC="^DPT(",DIC(0)="QEAZM" D ^DIC G END:Y<0 S DFN=+Y - I $P($G(^DPT(DFN,.361)),"^")="" W !!,"ELIGIBILITY HAS NOT BEEN DETERMINED NOR PENDING, CANNOT ENTER AN AUTHORIZATION." G FBNHEAUT - 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.") - 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) - 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 - S:'$D(^FBAAA(DFN,1,0)) ^(0)="^161.01D^^" - D ^FBAADEM ;G FBNHEAUT:FBAAOUT - ; -GETVEN S FBPROG=7 D DATES^FBAAUTL2 G:FBBEGDT="" FBNHEAUT - 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) - D GETRAT^FBNHEAU2 G:FBERR GETVEN - ;CREATE AN ENTRY IN FILE 161 - 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 - S DIE=DIC,FBPSADF=$S($D(FBSITE(1)):$P(^DIC(4,$P(FBSITE(1),"^",3),0),"^",1),1:"") - ; fb*3.5*103 added REFERRING PROVIDER field (161.01,104) to DR string - 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 - I $D(DTOUT)!('$D(Y)=0) S DIC="^FBAAA("_DFN_",1," G DEL - ; fb*3.5*103 assignment of REFERRING PROVIDER (161.01,104) for recording at 162.4,15 via the FBNH ENTER 7078 input template - S FBRP=$$GET1^DIQ(161.01,FBAAADA_","_DFN,104,"I") - S FBVEN=FBVEN_";FBAAV(" - ; - 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) - D EST^FBNHEAU2 - 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 - ;CHECK 1358 and get next point number. create entry in 162.4 - 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 - 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 - S (DA,FBAA78)=+Y - S DIE=DIC,DR="[FBNH ENTER 7078]" D ^DIE - 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) - S $P(^FBAAA(DFN,1,FBAAADA,0),"^",9)=FBAA78_";FB7078(",^FBAAA("AG",FBAA78_";FB7078(",DFN,FBAAADA)="" - ;call to create entries in file 161.23, time sensitive file - ;that will store patient rates - S FBERR=0 D FILE^FBNHEAU2 I FBERR W !,"Unable to create entry in Authorization Rate file (161.23). Contact IRM.",! G ADM - ;call to create entry in ifcap 424. - S FBMM=$E(FBBEGDT,4,5) - 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 - 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 - W !!,$J(FBDEFP,7,2)," Posted to 1358" - ; - ; -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 ! - D IFCAP^FBAAUTL2 - 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 - ; -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 - ; -END D END^FBNHEAU1 - Q - ; -DEL S DIK=DIC D ^DIK K DIK,DIC D END^FBNHEAU1 G FBNHEAUT +FBNHEAUT ;AISC/DMK,GRR-ENTER/EDIT AUTHORIZATION ;08/07/02 + ;;3.5;FEE BASIS;**43**;JAN 30, 1995 + ;;Per VHA Directive 10-93-142, this routine should not be modified. + 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 !! + ; + 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") + ; + W !! S DIC="^DPT(",DIC(0)="QEAZM" D ^DIC G END:Y<0 S DFN=+Y + I $P($G(^DPT(DFN,.361)),"^")="" W !!,"ELIGIBILITY HAS NOT BEEN DETERMINED NOR PENDING, CANNOT ENTER AN AUTHORIZATION." G FBNHEAUT + 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.") + 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) + 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 + S:'$D(^FBAAA(DFN,1,0)) ^(0)="^161.01D^^" + D ^FBAADEM ;G FBNHEAUT:FBAAOUT + ; +GETVEN S FBPROG=7 D DATES^FBAAUTL2 G:FBBEGDT="" FBNHEAUT + 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) + D GETRAT^FBNHEAU2 G:FBERR GETVEN + ;CREATE AN ENTRY IN FILE 161 + 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 + S DIE=DIC,FBPSADF=$S($D(FBSITE(1)):$P(^DIC(4,$P(FBSITE(1),"^",3),0),"^",1),1:"") + 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 + I $D(DTOUT)!('$D(Y)=0) S DIC="^FBAAA("_DFN_",1," G DEL + S FBVEN=FBVEN_";FBAAV(" + ; + 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) + D EST^FBNHEAU2 + 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 + ;CHECK 1358 and get next point number. create entry in 162.4 + 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 + 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 + S (DA,FBAA78)=+Y + S DIE=DIC,DR="[FBNH ENTER 7078]" D ^DIE + 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) + S $P(^FBAAA(DFN,1,FBAAADA,0),"^",9)=FBAA78_";FB7078(",^FBAAA("AG",FBAA78_";FB7078(",DFN,FBAAADA)="" + ;call to create entries in file 161.23, time sensitive file + ;that will store patient rates + S FBERR=0 D FILE^FBNHEAU2 I FBERR W !,"Unable to create entry in Authorization Rate file (161.23). Contact IRM.",! G ADM + ;call to create entry in ifcap 424. + S FBMM=$E(FBBEGDT,4,5) + 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 + 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 + W !!,$J(FBDEFP,7,2)," Posted to 1358" + ; + ; +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 ! + D IFCAP^FBAAUTL2 + 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 + ; +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 + ; +END D END^FBNHEAU1 + Q + ; +DEL S DIK=DIC D ^DIK K DIK,DIC D END^FBNHEAU1 G FBNHEAUT Index: WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBNHEDAT.m =================================================================== --- WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBNHEDAT.m (revision 613) +++ WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBNHEDAT.m (revision 623) @@ -1,40 +1,39 @@ -FBNHEDAT ;AISC/GRR-ENTER/EDIT AUTHORIZATION ;02:07 PM 11 Apr 1990; - ;;3.5;FEE BASIS;**103**;JAN 30, 1995;Build 19 - ;;Per VHA Directive 2004-038, this routine should not be modified. - D SITEP^FBAAUTL -RD1 S U="^" D GETVET^FBAAUTL1 G:DFN="" END - S FBPROG="I $P(^(0),U,3)=7" D GETAUTH^FBAAUTL1 G RD1:'CNT!(FTP']"")!($D(DIRUT)) S (FBOLD,FBNEW,FBERR)="" - 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) - S FBPROG=7 D DATES^FBAAUTL2 S FBAA(1)=$S($G(FBBEGDT):FBBEGDT,1:FBO),FBAA(2)=$S($G(FBENDDT):FBENDDT,1:FB1) -DR S DR=".01////^S X=FBAA(1);.02////^S X=FBAA(2)" - ; fb*3.5*103 add REFERRING PROVIDER (161.01,104) to DR string - 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 - S FBNEW=$S('$D(DA):"",'$D(^FBAAA(DFN,1,DA,0)):"",1:^(0)) K DR - I $D(Y)>0,FBNEW=""!(FBNEW=FBOLD) G RD1 - 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 - ; - 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 - ; fb*3.5*103 add the REFERRING PROVIDER (162.4,15) to the DR string; stuff with the value stored at 161.01,104 - 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 - D:FBOLD'=FBNEW CHANGED -GO D ^DIE - 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) -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 -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 ! - S VAR="FB7078^FBNUM^FBO^FBT^FB(""SITE"")",VAL=FB7078_"^"_FBNUM_"^"_FBO_"^"_FBT_"^"_FB("SITE"),PGM="START^FBCHP78" W ! D ZIS^FBAAUTL - ; -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 - 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 - D END^FBNHEAU1 - D CLOSE^FBAAUTL - Q - ; -CHANGED S:$P(FBOLD,"^",1)'=$P(FBNEW,"^",1) DR="3////^S X=$P(FBNEW,U,1);"_DR - S:$P(FBOLD,"^",2)'=$P(FBNEW,"^",2) DR="4////^S X=$P(FBNEW,U,2);"_DR - Q - ; -ER W !,*7,"From Date cannot be greater than the To Date.",! - Q - ; -ER1 W !,*7,"This patient has movements after the authorization to date. You must",!,"edit the patient's movements first.",! - Q +FBNHEDAT ;AISC/GRR-ENTER/EDIT AUTHORIZATION ;02:07 PM 11 Apr 1990; + ;;3.5;FEE BASIS;;JAN 30, 1995 + ;;Per VHA Directive 10-93-142, this routine should not be modified. + D SITEP^FBAAUTL +RD1 S U="^" D GETVET^FBAAUTL1 G:DFN="" END + S FBPROG="I $P(^(0),U,3)=7" D GETAUTH^FBAAUTL1 G RD1:'CNT!(FTP']"")!($D(DIRUT)) S (FBOLD,FBNEW,FBERR)="" + 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) + S FBPROG=7 D DATES^FBAAUTL2 S FBAA(1)=$S($G(FBBEGDT):FBBEGDT,1:FBO),FBAA(2)=$S($G(FBENDDT):FBENDDT,1:FB1) +DR S DR=".01////^S X=FBAA(1);.02////^S X=FBAA(2)" + 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 + S FBNEW=$S('$D(DA):"",'$D(^FBAAA(DFN,1,DA,0)):"",1:^(0)) K DR + I $D(Y)>0,FBNEW=""!(FBNEW=FBOLD) G RD1 + 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 + ; + 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 + ; + S DIE="^FB7078(",DA=FB7078,FBAA78=DA,DR="5;6" I 'DA W !!,*7,"No 7078 on file!",! G END + D:FBOLD'=FBNEW CHANGED +GO D ^DIE + 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) +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 +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 ! + S VAR="FB7078^FBNUM^FBO^FBT^FB(""SITE"")",VAL=FB7078_"^"_FBNUM_"^"_FBO_"^"_FBT_"^"_FB("SITE"),PGM="START^FBCHP78" W ! D ZIS^FBAAUTL + ; +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 + 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 + D END^FBNHEAU1 + D CLOSE^FBAAUTL + Q + ; +CHANGED S:$P(FBOLD,"^",1)'=$P(FBNEW,"^",1) DR="3////^S X=$P(FBNEW,U,1);"_DR + S:$P(FBOLD,"^",2)'=$P(FBNEW,"^",2) DR="4////^S X=$P(FBNEW,U,2);"_DR + Q + ; +ER W !,*7,"From Date cannot be greater than the To Date.",! + Q + ; +ER1 W !,*7,"This patient has movements after the authorization to date. You must",!,"edit the patient's movements first.",! + Q Index: WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBPCR.m =================================================================== --- WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBPCR.m (revision 613) +++ WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBPCR.m (revision 623) @@ -1,172 +1,171 @@ -FBPCR ;AISC/DMK,GRR,TET-POTENTIAL COST RECOVERY OUTPUT DRIVER ;23 May 2006 10:06 AM - ;;3.5;FEE BASIS;**12,48,76,98,103**;JAN 30, 1995;Build 19 - ;;Per VHA Directive 2004-038, this routine should not be modified. - ; DBIA SUPPORTED REF $$NPI^XUSNPI = 4532 -DOC ;Refer to fbdoc, tag fbpcr, for documentation of fbpcr* routines -PSF ;select one/many/all primary service failities - S FBARRLTC="" - W !! S DIC="^DIC(4,",VAUTSTR="Primary Service Facility",VAUTNI=2,VAUTVB="FBPSV" D FIRST^VAUTOMA K DIC I Y=-1 G EXIT -ARRAY ;set fee program array for all programs - 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) - I '$D(FBPROG) G EXIT - ;prepare array with LTC POV codes - D MKARRLTC^FBPCR4 - ;what party to include - K DIR - S DIR(0)="SO^P:Patient;I:Insurance;B:Both",DIR("A")="Include (P)atient Co-pays / (I)nsurance / (B)oth",DIR("B")="Both" - 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")="" - 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) - K DIR - G:FBPARTY=0 EXIT - ;what type of copay to include - S FBCOPAY=3 - I FBPARTY'=2 D - . 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" - . 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")="" - . 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) - . K DIR - G:FBCOPAY=0 EXIT - ; - ;include patients if their insurance informations is unavailable? - S FBINCUNK=0 - I FBPARTY=2!(FBPARTY=3) D - . S FBINCUNK=1 - . N Y,X - . W !! - . S DIR("A")="Do you want to include patients whose insurance status is unavailable? " - . S DIR("?")="Please answer Yes or No." - . S DIR("B")="YES",DIR(0)="YA^^" - . D ^DIR K DIR - . I $G(DIRUT) S FBINCUNK=-1 Q - . I $G(Y)=0 S FBINCUNK=0 - I FBINCUNK=-1 G EXIT ;uparrow - exit - ; -DATE ;select date range - D DATE^FBAAUTL I FBPOP G PSF - S FBBDATE=BEGDATE,FBEDATE=ENDDATE - S Z=9999999.9999,FBBEG=Z-FBEDATE,FBEND=Z-FBBDATE -Q K ^TMP($J,"FB"),^TMP($J,"FBINSIBAPI"),DIC - ; - 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 -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 -SORT ;sort driver for payment output(s) - S FBPI=0 F S FBPI=$O(FBPROG(FBPI)) Q:'FBPI S FBXPROG=FBPROG(FBPI) D - .I FBPI=2 D EN^FBPCR2 ;outpatient payments - .I FBPI=3 D EN^FBPCR3 ;pharmacy payments - .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 -PRINT ;print driver for payment output(s) - I $G(^TMP($J,"FBINSIBAPI"))>0 D HDRUNK - S FBPI=$O(^TMP($J,"FB",0)) I FBPI']"" D WMSG G OUT - S FBSTA=0 - 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 - .I FBPSF_FBPT'=FBSTA D HDR Q:FBOUT - .I FBPI=2,$D(^TMP($J,"FB",FBPSF,FBPT,FBPI)) D PRINT^FBPCR2 Q - .I FBPI=3 D:$D(^TMP($J,"FB",FBPSF,FBPT,FBPI)) PRINT^FBPCR3 Q - .I FBPI=6!(FBPI=7) D:$D(^TMP($J,"FB",FBPSF,FBPT,FBPI)) PRINT^FBPCR671 Q -OUT I $G(^TMP($J,"FBINSIBAPI"))>0 D ERRHDL^FBPCR4 - I FBOUT!$D(ZTQUEUED) G EXIT - D EXIT G PSF - Q -EXIT ;kill and quit -KILL ;kill all variables set in the FBPCR* routines, other than fbx - D CLOSE^FBAAUTL K ^TMP($J,"FB") - K A1,A2,A3,BEGDATE,C,D,D2,DFN,DIC,DIR,DTOUT,DUOUT,ENDDATE,FBPDXC,FBPARTY,FBCOPAY,FBARRLTC,FBINCUNK - 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 - 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 - 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 - Q -WMSG ;write message if no matches found - D HDR W !!?3,"There are no potential cost recoveries on file" - W !?5,"for specified date range: ",$$DATX^FBAAUTL(FBBDATE)," through ",$$DATX^FBAAUTL(FBEDATE) - I 'FBPSV D - .W ",",!?5,"and selected Primary Service Area(s):" - .S FBPSF=0 F S FBPSF=$O(FBPSV(FBPSF)) Q:'FBPSF W !?31,$G(FBPSV(FBPSF)) - E W !?5,"and ALL Primary Service Areas " - W ".",*7,!! - Q - ; -CATC(DFN,FBDT,FBPOV) ; - ;treats all copays as Means test for date < 3020705 (JULY 5,2002) - ;check if patient is liable for copay - ;INPUT: - ; DFN = IEN of Patient file - ; FBDT= Date - ; FBPOV = POV code (for LTC determination) - ;OUTPUT: - ;0 - the patient is not liable for any co-pay; - ;1 - if Means test catc or pending adjudication and agree to pay deduc - ;2 - the patient is liable for LTC co-pay; - ;3 - no 1010EC on file - ;4 - more analysis is needed to determine the patient liability - N FBLTC,FBISLTC - S FBCATC=$$BIL^DGMTUB(DFN,FBDT) - I '$D(FBPOV)!(FBDT<3020705) Q $S(FBCATC:1,1:0) - S FBISLTC=$$ISLTC^FBPCR4(FBPOV) - I FBISLTC=0 Q $S(FBCATC:1,1:0) ;Means test - I FBISLTC=2 Q 0 ;LTC-service, but LTC-copay is not applicable - S FBLTC=$$LTCST^FBPCR4(DFN,FBDT) - I FBLTC=2 Q 2 ;LTC copay - I FBLTC=0 Q 3 ;no 1010EC on file - I FBLTC=4 Q 4 ;more info needed - Q 0 ;exemption from LTC -copay - ; -VET ;set vet name/ssn/dob info - ;INPUT: DFN = IEN of Patient file - ; FBPI = IEN of fee program (optional) - ;OUTPUT: FBPNAME = Patient's name - ; FBPID = Patient's pid - ; FBDOB = Patient's dob (if pharmacy fee program) - N N - S N=$G(^DPT(DFN,0)),FBPNAME=$P(N,U),FBPID=$$SSN^FBAAUTL(DFN),FBDOB=$$FMTE^XLFDT($P(N,U,3)) - Q -STA ;set station name & number - ;INPUT = FBPSF - IEN to institution file - ;OUTPUT = FBPSFNAM = station name - ; FBPSFNUM = station number - S FBPSFNAM=$P($G(^DIC(4,FBPSF,0)),U),FBPSFNUM=$P($G(^DIC(4,FBPSF,99)),U) - S:FBPSFNAM=+FBPSFNAM FBPSFNAM="UNKNOWN" - S FBSTANPI=$S($G(FBPSFNAM)="":"",FBPSFNAM="UNKNOWN":"",1:$P($$NPI^XUSNPI("Organization_ID",FBPSF),U,1)) - Q -PAGE ;form feed when new station/patient - S FBSTA=$G(FBPSF)_$G(FBPT) - I FBCRT&(FBPG'=0) D CR Q:FBOUT - I FBPG>0!FBCRT W @IOF - S FBPG=FBPG+1 - Q -CR ;read for display - S DIR(0)="E" W ! D ^DIR K DIR S:$D(DUOUT)!($D(DTOUT)) FBOUT=1 - Q -HDR ;general header for potential recoveries - D PAGE Q:FBOUT - W !?(IOM-30/2),"POTENTIAL COST RECOVERY REPORT" - W !?(IOM-(11+$L($G(FBPSFNAM))+$L($G(FBPSFNUM)))/2),"Division: ",$G(FBPSFNUM)," ",$G(FBPSFNAM) - W !?(IOM-14/2),"NPI: ",$S($G(FBSTANPI)="":"",$G(FBSTANPI)<1:"",1:$G(FBSTANPI)) - W !?(IOM-19/2),$$DATX^FBAAUTL(FBBDATE)," - ",$$DATX^FBAAUTL(FBEDATE) - W !?71,"Page: ",FBPG - W !,"Patient: ",$G(FBPNAME),?40,"Pat. ID: ",$G(FBPID),?62,"DOB: ",$G(FBDOB) - W ! - I FBINCUNK=1,$D(^TMP($J,"FBINSIBAPI",+$G(DFN))) W ">> Warning: accurate insurance information for the patient is unavailable" - W !?3,"('*' Represents Reimbursement to Patient",?50,"'#' Represents Voided Payment)" - W !,FBDASH - W ! D:$D(DFN) INS^DGRPDB - Q -HDRUNK ;Warning message if patient's insurance status is unknown - D PAGE Q:FBOUT - W !?(IOM-30/2),"POTENTIAL COST RECOVERY REPORT" - W !?(IOM-(11+$L($G(FBPSFNAM))+$L($G(FBPSFNUM)))/2),"Division: ",$G(FBPSFNUM)," ",$G(FBPSFNAM) - W !?(IOM-19/2),$$DATX^FBAAUTL(FBBDATE)," - ",$$DATX^FBAAUTL(FBEDATE) - W !?71,"Page: ",FBPG - W !,"------------------------------ !!! WARNING !!! --------------------------------" - W !,"This report is incomplete due to problems with obtaining insurance information" - W !,"for those patients listed in a separate section in the end of the report. You" - W !,"may want to rerun the report again to get more accurate results." - W !,FBDASH - I FBINCUNK=1 D - . W !,"Note: You have chosen to include patients with unknown insurance status in" - . W !,"this report. Please be aware that these patients will be treated as if they" - . W !,"have billable insurance and their treatment details will be marked accordingly." - . W !,"The names of these patients will be accompanied with the following message" - . W !,"to order to identify them:" - . W !,">> Warning: accurate insurance information for the patient is unavailable" - . W !,FBDASH - Q +FBPCR ;AISC/DMK,GRR,TET-POTENTIAL COST RECOVERY OUTPUT DRIVER ;23 May 2006 10:06 AM + ;;3.5;FEE BASIS;**12,48,76,98**;JAN 30, 1995;Build 54 + ;;Per VHA Directive 10-93-142, this routine should not be modified. +DOC ;Refer to fbdoc, tag fbpcr, for documentation of fbpcr* routines +PSF ;select one/many/all primary service failities + S FBARRLTC="" + W !! S DIC="^DIC(4,",VAUTSTR="Primary Service Facility",VAUTNI=2,VAUTVB="FBPSV" D FIRST^VAUTOMA K DIC I Y=-1 G EXIT +ARRAY ;set fee program array for all programs + 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) + I '$D(FBPROG) G EXIT + ;prepare array with LTC POV codes + D MKARRLTC^FBPCR4 + ;what party to include + K DIR + S DIR(0)="SO^P:Patient;I:Insurance;B:Both",DIR("A")="Include (P)atient Co-pays / (I)nsurance / (B)oth",DIR("B")="Both" + 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")="" + 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) + K DIR + G:FBPARTY=0 EXIT + ;what type of copay to include + S FBCOPAY=3 + I FBPARTY'=2 D + . 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" + . 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")="" + . 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) + . K DIR + G:FBCOPAY=0 EXIT + ; + ;include patients if their insurance informations is unavailable? + S FBINCUNK=0 + I FBPARTY=2!(FBPARTY=3) D + . S FBINCUNK=1 + . N Y,X + . W !! + . S DIR("A")="Do you want to include patients whose insurance status is unavailable? " + . S DIR("?")="Please answer Yes or No." + . S DIR("B")="YES",DIR(0)="YA^^" + . D ^DIR K DIR + . I $G(DIRUT) S FBINCUNK=-1 Q + . I $G(Y)=0 S FBINCUNK=0 + I FBINCUNK=-1 G EXIT ;uparrow - exit + ; +DATE ;select date range + D DATE^FBAAUTL I FBPOP G PSF + S FBBDATE=BEGDATE,FBEDATE=ENDDATE + S Z=9999999.9999,FBBEG=Z-FBEDATE,FBEND=Z-FBBDATE +Q K ^TMP($J,"FB"),^TMP($J,"FBINSIBAPI"),DIC + ; + 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 +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 +SORT ;sort driver for payment output(s) + S FBPI=0 F S FBPI=$O(FBPROG(FBPI)) Q:'FBPI S FBXPROG=FBPROG(FBPI) D + .I FBPI=2 D EN^FBPCR2 ;outpatient payments + .I FBPI=3 D EN^FBPCR3 ;pharmacy payments + .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 +PRINT ;print driver for payment output(s) + I $G(^TMP($J,"FBINSIBAPI"))>0 D HDRUNK + S FBPI=$O(^TMP($J,"FB",0)) I FBPI']"" D WMSG G OUT + S FBSTA=0 + 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 + .I FBPSF_FBPT'=FBSTA D HDR Q:FBOUT + .I FBPI=2,$D(^TMP($J,"FB",FBPSF,FBPT,FBPI)) D PRINT^FBPCR2 Q + .I FBPI=3 D:$D(^TMP($J,"FB",FBPSF,FBPT,FBPI)) PRINT^FBPCR3 Q + .I FBPI=6!(FBPI=7) D:$D(^TMP($J,"FB",FBPSF,FBPT,FBPI)) PRINT^FBPCR671 Q +OUT I $G(^TMP($J,"FBINSIBAPI"))>0 D ERRHDL^FBPCR4 + I FBOUT!$D(ZTQUEUED) G EXIT + D EXIT G PSF + Q +EXIT ;kill and quit +KILL ;kill all variables set in the FBPCR* routines, other than fbx + D CLOSE^FBAAUTL K ^TMP($J,"FB") + K A1,A2,A3,BEGDATE,C,D,D2,DFN,DIC,DIR,DTOUT,DUOUT,ENDDATE,FBPDXC,FBPARTY,FBCOPAY,FBARRLTC,FBINCUNK + 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 + 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 + 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 + Q +WMSG ;write message if no matches found + D HDR W !!?3,"There are no potential cost recoveries on file" + W !?5,"for specified date range: ",$$DATX^FBAAUTL(FBBDATE)," through ",$$DATX^FBAAUTL(FBEDATE) + I 'FBPSV D + .W ",",!?5,"and selected Primary Service Area(s):" + .S FBPSF=0 F S FBPSF=$O(FBPSV(FBPSF)) Q:'FBPSF W !?31,$G(FBPSV(FBPSF)) + E W !?5,"and ALL Primary Service Areas " + W ".",*7,!! + Q + ; +CATC(DFN,FBDT,FBPOV) ; + ;treats all copays as Means test for date < 3020705 (JULY 5,2002) + ;check if patient is liable for copay + ;INPUT: + ; DFN = IEN of Patient file + ; FBDT= Date + ; FBPOV = POV code (for LTC determination) + ;OUTPUT: + ;0 - the patient is not liable for any co-pay; + ;1 - if Means test catc or pending adjudication and agree to pay deduc + ;2 - the patient is liable for LTC co-pay; + ;3 - no 1010EC on file + ;4 - more analysis is needed to determine the patient liability + N FBLTC,FBISLTC + S FBCATC=$$BIL^DGMTUB(DFN,FBDT) + I '$D(FBPOV)!(FBDT<3020705) Q $S(FBCATC:1,1:0) + S FBISLTC=$$ISLTC^FBPCR4(FBPOV) + I FBISLTC=0 Q $S(FBCATC:1,1:0) ;Means test + I FBISLTC=2 Q 0 ;LTC-service, but LTC-copay is not applicable + S FBLTC=$$LTCST^FBPCR4(DFN,FBDT) + I FBLTC=2 Q 2 ;LTC copay + I FBLTC=0 Q 3 ;no 1010EC on file + I FBLTC=4 Q 4 ;more info needed + Q 0 ;exemption from LTC -copay + ; +VET ;set vet name/ssn/dob info + ;INPUT: DFN = IEN of Patient file + ; FBPI = IEN of fee program (optional) + ;OUTPUT: FBPNAME = Patient's name + ; FBPID = Patient's pid + ; FBDOB = Patient's dob (if pharmacy fee program) + N N + S N=$G(^DPT(DFN,0)),FBPNAME=$P(N,U),FBPID=$$SSN^FBAAUTL(DFN),FBDOB=$$FMTE^XLFDT($P(N,U,3)) + Q +STA ;set station name & number + ;INPUT = FBPSF - IEN to institution file + ;OUTPUT = FBPSFNAM = station name + ; FBPSFNUM = station number + S FBPSFNAM=$P($G(^DIC(4,FBPSF,0)),U),FBPSFNUM=$P($G(^DIC(4,FBPSF,99)),U) + S:FBPSFNAM=+FBPSFNAM FBPSFNAM="UNKNOWN" + S FBSTANPI=$S($G(FBPSFNAM)="":"",FBPSFNAM="UNKNOWN":"",1:$P($$NPI^XUSNPI("Organization_ID",FBPSF),U,1)) + Q +PAGE ;form feed when new station/patient + S FBSTA=$G(FBPSF)_$G(FBPT) + I FBCRT&(FBPG'=0) D CR Q:FBOUT + I FBPG>0!FBCRT W @IOF + S FBPG=FBPG+1 + Q +CR ;read for display + S DIR(0)="E" W ! D ^DIR K DIR S:$D(DUOUT)!($D(DTOUT)) FBOUT=1 + Q +HDR ;general header for potential recoveries + D PAGE Q:FBOUT + W !?(IOM-30/2),"POTENTIAL COST RECOVERY REPORT" + W !?(IOM-(11+$L($G(FBPSFNAM))+$L($G(FBPSFNUM)))/2),"Division: ",$G(FBPSFNUM)," ",$G(FBPSFNAM) + W !?(IOM-14/2),"NPI: ",$S($G(FBSTANPI)="":"",$G(FBSTANPI)=-1:"",1:$G(FBSTANPI)) + W !?(IOM-19/2),$$DATX^FBAAUTL(FBBDATE)," - ",$$DATX^FBAAUTL(FBEDATE) + W !?71,"Page: ",FBPG + W !,"Patient: ",$G(FBPNAME),?40,"Pat. ID: ",$G(FBPID),?62,"DOB: ",$G(FBDOB) + W ! + I FBINCUNK=1,$D(^TMP($J,"FBINSIBAPI",+$G(DFN))) W ">> Warning: accurate insurance information for the patient is unavailable" + W !?3,"('*' Represents Reimbursement to Patient",?50,"'#' Represents Voided Payment)" + W !,FBDASH + W ! D:$D(DFN) INS^DGRPDB + Q +HDRUNK ;Warning message if patient's insurance status is unknown + D PAGE Q:FBOUT + W !?(IOM-30/2),"POTENTIAL COST RECOVERY REPORT" + W !?(IOM-(11+$L($G(FBPSFNAM))+$L($G(FBPSFNUM)))/2),"Division: ",$G(FBPSFNUM)," ",$G(FBPSFNAM) + W !?(IOM-19/2),$$DATX^FBAAUTL(FBBDATE)," - ",$$DATX^FBAAUTL(FBEDATE) + W !?71,"Page: ",FBPG + W !,"------------------------------ !!! WARNING !!! --------------------------------" + W !,"This report is incomplete due to problems with obtaining insurance information" + W !,"for those patients listed in a separate section in the end of the report. You" + W !,"may want to rerun the report again to get more accurate results." + W !,FBDASH + I FBINCUNK=1 D + . W !,"Note: You have chosen to include patients with unknown insurance status in" + . W !,"this report. Please be aware that these patients will be treated as if they" + . W !,"have billable insurance and their treatment details will be marked accordingly." + . W !,"The names of these patients will be accompanied with the following message" + . W !,"to order to identify them:" + . W !,">> Warning: accurate insurance information for the patient is unavailable" + . W !,FBDASH + Q