Changeset 623 for WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBAA79.m
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
-
WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBAA79.m (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBAA79.m
r613 r623 1 FBAA79 ;AISC/GRR-PRINT FORM 7079 REQUEST FOR OUTPATIENT MEDICAL SERVICES ;7/NOV/2006 2 ;;3.5;FEE BASIS;**12,23,101,103**;JAN 30, 1995;Build 19 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 W !,"Print 7079's for: " D DT^DICRW,DATE^FBAAUTL G:FBPOP END D SITEP^FBAAUTL G:FBPOP END 5 I '$D(^FBAAA("AF",2)) W !!,*7,"There are no 7079's to be printed!",! G END 6 S FBAASCR="" 7 RDHOW W ! S DIR("A")="Want only those that have not yet been printed",DIR("B")="Yes",DIR(0)="Y" D ^DIR K DIR G END:$D(DIRUT) S:Y FBAASCR="Y" 8 D OUTPUT^FBAAS79 9 S VAR="BEGDATE^ENDDATE^FBAASCR",VAL=BEGDATE_"^"_ENDDATE_"^"_FBAASCR,PGM="START^FBAA79",IOP="Q" D ZIS^FBAAUTL G:FBPOP END 10 START D SITEP^FBAAUTL G END:FBPOP 11 S UL="",ULL="----------",FBPG=0 F Z=1:1:12 S UL=UL_ULL 12 U IO S FBAASCR=$S(FBAASCR="":"I 1",FBAASCR="Y":"I $S('$D(^FBAAA(DFN,1,FBK,1)):1,$P(^FBAAA(DFN,1,FBK,1),""^"",2)']"""":1,1:0)",1:"I 1") 13 S FBJ=BEGDATE-.001,(DFN,FBK)=0 F ZZ=0:0 S FBJ=$O(^FBAAA("AF",2,FBJ)) Q:FBJ'>0!(FBJ>ENDDATE) F S DFN=$O(^FBAAA("AF",2,FBJ,DFN)) Q:DFN'>0 F S FBK=$O(^FBAAA("AF",2,FBJ,DFN,FBK)) Q:FBK'>0 X FBAASCR I D GOT 14 END K FBJ,FBK,DFN,Z,FBS,V,FBI,FBPATT,FBPG,FBSITE,UL,ULL,POV,NOV,POS,CC,PSTCD,SSTCD,VSTCD,BEGDATE,ENDDATE,PIDC,REF,VDX,CODE,STATCD,D,FBAASCR,FBDX,FBIDC,FBOUT,FBPDX,FBREM,FBRR,NAME,PGM,POW,VAL,VAR,VFN,VFROM,VTO,YOB,ZZ 15 K FB7078,FBAABDT,FBAAEDT,FBASSOC,FBLOC,FBPOV,FBPSA,FBPT,FBTT,FBTYPE,FBVEN,FTP,CNT,FBAAOUT,FBAUT,FBPROG,I,J,M,PI,Q,SEX,SSN,TA,DATE,S,Y,DA,DIC 16 D CLOSE^FBAAUTL Q 17 Q 18 ; 19 ; Utilize new API for Name Standardization 20 ; 21 GOT Q:'$D(^DPT(DFN,0)) 22 S Y(0)=^DPT(DFN,0) 23 D 24 .N FBNAMES 25 .S FBNAMES("FILE")=2,FBNAMES("IENS")=DFN_",",FBNAMES("FIELD")=.01 26 .S NAME=$$NAMEFMT^XLFNAME(.FBNAMES) 27 S SEX=$P(Y(0),U,2) 28 S SSN=$TR($$SSNL4^FBAAUTL($$SSN^FBAAUTL(DFN)),"-",""),YOB=$S($P(Y(0),U,3)]"":$E($P(Y(0),U,3),1,3)+1700,1:""),POS=$S($D(^DPT(DFN,.32)):$P(^(.32),"^",3),1:""),POS=$S(POS]"":$P(^DIC(21,POS,0),"^",3),1:"") 29 F I=1:1:7 S FBI(I)="" 30 I $D(^DPT(DFN,.11)) F I=1:1:7 S FBI(I)=$P(^(.11),"^",I) 31 S POW=$P($G(^DPT(DFN,.52)),"^",5) 32 Q:'$D(^FBAAA(DFN,1,FBK)) S Y(0)=^(FBK,0),VFROM=$P(Y(0),"^",1),VTO=$P(Y(0),"^",2),VFN=$P(Y(0),"^",4) I $S($P(Y(0),"^",3)=6:1,$P(Y(0),"^",3)=7:1,1:"") Q 33 S VDX=$P(Y(0),"^",8),FBPATT=$P(Y(0),"^",18),POV=$$EXTPV^FBAAUTL5($P(Y(0),"^",7)),CODE=$P(Y(0),"^",13),PIDC=$P(Y(0),"^",12),REF=$P(Y(0),"^",21) 34 S NOV=$P($G(^FBAAA(DFN,1,FBK,1)),"^") 35 S FBDX=$G(^FBAAA(DFN,1,FBK,3)) 36 S FBIDC=$P($G(^FBAAA(DFN,4)),"^") 37 S STATCD=FBI(5),CC=FBI(7) F V=1:1:14 S V(V)="" 38 S CC=$S(CC']"":"",$D(^DIC(5,+STATCD,1,CC,0)):$P(^(0),"^",3),1:"") 39 S Y(0)=$S(VFN']"":"",'$D(^FBAAV(VFN,0)):"",$D(^FBAAV(VFN,0)):^(0),1:"") G:$S(VFN']"":1,'$D(^FBAAV(VFN,0)):1,1:0) OVR 40 F V=2,1,3,14,4,5,6,10 S V(V)=$P(Y(0),"^",V) 41 OVR F S=1:1:9 S FBS(S)=$P(FBSITE(0),"^",S) 42 S VSTCD=$S(V(5)']"":" ",$D(^DIC(5,V(5),0)):$P(^(0),"^",2),1:" "),SSTCD=$S(FBS(5)']"":" ",$D(^DIC(5,+FBS(5),0)):$P(^(0),"^",2),1:" "),PSTCD=$S(FBI(5)']"":" ",$D(^DIC(5,+FBI(5),0)):$P(^(0),"^",2),1:" ") 43 W:FBPG @IOF W UL,!,?46,"Department of Veterans Affairs",?100,"ID Card Number: ",FBIDC,!,?35,"R E Q U E S T F O R O U T P A T I E N T S E R V I C E S",!,UL S FBREM=0,FBOUT=0 44 ; 45 W !,"(1) Veterans Name",?31,"|(2) ID Number | Period of Validity",!,?31,"|",?46,"|" 46 W !,NAME,?31,"|",?32,SSN,?46,"|"," FROM: ",$$FMTE^XLFDT(VFROM)," TO: ",$$FMTE^XLFDT(VTO),!,UL 47 W !,"(3) ADDRESS",?31,"|DATE OF ISSUE",?46,"| CONDITIONS FOR WHICH SERVICES ARE REQUESTED (DESCRIPTION OF DISABILITY)",!,?31,"|",?46,"|" 48 W !,FBI(1),?31,"|",?33,$$FMTE^XLFDT(FBJ),?46,"|"," ",VDX S FBPDX=0 49 I FBI(2)]"" W !,FBI(2),?31,"|",?46,"|"," " S FBPDX=FBPDX+1 W ?48,$P(FBDX,"^",FBPDX) 50 I FBI(3)]"" W !,FBI(3),?31,"|",?46,"|"," " S FBPDX=FBPDX+1 W ?48,$P(FBDX,"^",FBPDX) 51 W !,FBI(4)," ",PSTCD," ",FBI(6),?31,"|",?46,"|" S FBPDX=FBPDX+1 W ?48,$P(FBDX,"^",FBPDX),!,$E(UL,1,45),?46,"|" S FBPDX=FBPDX+1 W ?48,$P(FBDX,"^",FBPDX) 52 W !,"Name and Address of Fee Participant",?46,"|" S FBPDX=FBPDX+1 W ?48,$P(FBDX,"^",FBPDX) 53 W !,?46,"|",!,V(1),?46,"|",!,V(3),?46,"|" W:V(14)]"" !,V(14),?46,"|" 54 ; PRXM/KJH - Patch 103. Add Referring Provider and NPI to the display. 55 W !,V(4)," ",VSTCD," ",V(6),?46,"|","REFERRING PROVIDER: " 56 I REF'="" W $$GET1^DIQ(200,REF,.01) 57 W !,V(2),?46,"|","NPI: ",$$REFNPI^FBCH78(REF,"",1) 58 W !,?46,"|","AUTHORIZATION #: ",DFN,"-",FBK,!,UL,! 59 W ?49,"AUTHORIZATION REMARKS",!,?49,$E(UL,1,21) 60 D ^FBAA79A S $P(^FBAAA(DFN,1,FBK,1),"^",2)=DT,FBPG=1 Q 1 FBAA79 ;AISC/GRR-PRINT FORM 7079 REQUEST FOR OUTPATIENT MEDICAL SERVICES ;7/NOV/2006 2 ;;3.5;FEE BASIS;**12,23,101**;JAN 30, 1995;Build 2 3 ;;Per VHA Directive 2004-038, this routine should not be modified. 4 W !,"Print 7079's for: " D DT^DICRW,DATE^FBAAUTL G:FBPOP END D SITEP^FBAAUTL G:FBPOP END 5 I '$D(^FBAAA("AF",2)) W !!,*7,"There are no 7079's to be printed!",! G END 6 S FBAASCR="" 7 RDHOW W ! S DIR("A")="Want only those that have not yet been printed",DIR("B")="Yes",DIR(0)="Y" D ^DIR K DIR G END:$D(DIRUT) S:Y FBAASCR="Y" 8 D OUTPUT^FBAAS79 9 S VAR="BEGDATE^ENDDATE^FBAASCR",VAL=BEGDATE_"^"_ENDDATE_"^"_FBAASCR,PGM="START^FBAA79",IOP="Q" D ZIS^FBAAUTL G:FBPOP END 10 START D SITEP^FBAAUTL G END:FBPOP 11 S UL="",ULL="----------",FBPG=0 F Z=1:1:12 S UL=UL_ULL 12 U IO S FBAASCR=$S(FBAASCR="":"I 1",FBAASCR="Y":"I $S('$D(^FBAAA(DFN,1,FBK,1)):1,$P(^FBAAA(DFN,1,FBK,1),""^"",2)']"""":1,1:0)",1:"I 1") 13 S FBJ=BEGDATE-.001,(DFN,FBK)=0 F ZZ=0:0 S FBJ=$O(^FBAAA("AF",2,FBJ)) Q:FBJ'>0!(FBJ>ENDDATE) F S DFN=$O(^FBAAA("AF",2,FBJ,DFN)) Q:DFN'>0 F S FBK=$O(^FBAAA("AF",2,FBJ,DFN,FBK)) Q:FBK'>0 X FBAASCR I D GOT 14 END K FBJ,FBK,DFN,Z,FBS,V,FBI,FBPATT,FBPG,FBSITE,UL,ULL,POV,NOV,POS,CC,PSTCD,SSTCD,VSTCD,BEGDATE,ENDDATE,PIDC,VDX,CODE,STATCD,D,FBAASCR,FBDX,FBIDC,FBOUT,FBPDX,FBREM,FBRR,NAME,PGM,POW,VAL,VAR,VFN,VFROM,VTO,YOB,ZZ 15 K FB7078,FBAABDT,FBAAEDT,FBASSOC,FBLOC,FBPOV,FBPSA,FBPT,FBTT,FBTYPE,FBVEN,FTP,CNT,FBAAOUT,FBAUT,FBPROG,I,J,M,PI,Q,SEX,SSN,TA,DATE,S,Y,DA,DIC 16 D CLOSE^FBAAUTL Q 17 Q 18 ; 19 ; Utilize new API for Name Standardization 20 ; 21 GOT Q:'$D(^DPT(DFN,0)) 22 S Y(0)=^DPT(DFN,0) 23 D 24 .N FBNAMES 25 .S FBNAMES("FILE")=2,FBNAMES("IENS")=DFN_",",FBNAMES("FIELD")=.01 26 .S NAME=$$NAMEFMT^XLFNAME(.FBNAMES) 27 S SEX=$P(Y(0),U,2) 28 S SSN=$TR($$SSNL4^FBAAUTL($$SSN^FBAAUTL(DFN)),"-",""),YOB=$S($P(Y(0),U,3)]"":$E($P(Y(0),U,3),1,3)+1700,1:""),POS=$S($D(^DPT(DFN,.32)):$P(^(.32),"^",3),1:""),POS=$S(POS]"":$P(^DIC(21,POS,0),"^",3),1:"") 29 F I=1:1:7 S FBI(I)="" 30 I $D(^DPT(DFN,.11)) F I=1:1:7 S FBI(I)=$P(^(.11),"^",I) 31 S POW=$P($G(^DPT(DFN,.52)),"^",5) 32 Q:'$D(^FBAAA(DFN,1,FBK)) S Y(0)=^(FBK,0),VFROM=$P(Y(0),"^",1),VTO=$P(Y(0),"^",2),VFN=$P(Y(0),"^",4) I $S($P(Y(0),"^",3)=6:1,$P(Y(0),"^",3)=7:1,1:"") Q 33 S VDX=$P(Y(0),"^",8),FBPATT=$P(Y(0),"^",18),POV=$$EXTPV^FBAAUTL5($P(Y(0),"^",7)),CODE=$P(Y(0),"^",13),PIDC=$P(Y(0),"^",12),NOV=$P($G(^FBAAA(DFN,1,FBK,1)),"^") 34 S FBDX=$G(^FBAAA(DFN,1,FBK,3)) 35 S FBIDC=$P($G(^FBAAA(DFN,4)),"^") 36 S STATCD=FBI(5),CC=FBI(7) F V=1:1:14 S V(V)="" 37 S CC=$S(CC']"":"",$D(^DIC(5,+STATCD,1,CC,0)):$P(^(0),"^",3),1:"") 38 S Y(0)=$S(VFN']"":"",'$D(^FBAAV(VFN,0)):"",$D(^FBAAV(VFN,0)):^(0),1:"") G:$S(VFN']"":1,'$D(^FBAAV(VFN,0)):1,1:0) OVR 39 F V=2,1,3,14,4,5,6,10 S V(V)=$P(Y(0),"^",V) 40 OVR F S=1:1:9 S FBS(S)=$P(FBSITE(0),"^",S) 41 S VSTCD=$S(V(5)']"":" ",$D(^DIC(5,V(5),0)):$P(^(0),"^",2),1:" "),SSTCD=$S(FBS(5)']"":" ",$D(^DIC(5,+FBS(5),0)):$P(^(0),"^",2),1:" "),PSTCD=$S(FBI(5)']"":" ",$D(^DIC(5,+FBI(5),0)):$P(^(0),"^",2),1:" ") 42 W:FBPG @IOF W UL,!,?46,"Department of Veterans Affairs",?100,"ID Card Number: ",FBIDC,!,?35,"R E Q U E S T F O R O U T P A T I E N T S E R V I C E S",!,UL S FBREM=0,FBOUT=0 43 ; 44 W !,"(1) Veterans Name",?31,"|(2) ID Number | Period of Validity",!,?31,"|",?46,"|" 45 W !,NAME,?31,"|",?32,SSN,?46,"|"," FROM: ",$$FMTE^XLFDT(VFROM)," TO: ",$$FMTE^XLFDT(VTO),!,UL 46 W !,"(3) ADDRESS",?31,"|DATE OF ISSUE",?46,"| CONDITIONS FOR WHICH SERVICES ARE REQUESTED (DESCRIPTION OF DISABILITY)",!,?31,"|",?46,"|" 47 W !,FBI(1),?31,"|",?33,$$FMTE^XLFDT(FBJ),?46,"|"," ",VDX S FBPDX=0 48 I FBI(2)]"" W !,FBI(2),?31,"|",?46,"|"," " S FBPDX=FBPDX+1 W ?48,$P(FBDX,"^",FBPDX) 49 I FBI(3)]"" W !,FBI(3),?31,"|",?46,"|"," " S FBPDX=FBPDX+1 W ?48,$P(FBDX,"^",FBPDX) 50 W !,FBI(4)," ",PSTCD," ",FBI(6),?31,"|",?46,"|" S FBPDX=FBPDX+1 W ?48,$P(FBDX,"^",FBPDX),!,$E(UL,1,45),?46,"|" S FBPDX=FBPDX+1 W ?48,$P(FBDX,"^",FBPDX) 51 W !,"Name and Address of Fee Participant",?46,"|" S FBPDX=FBPDX+1 W ?48,$P(FBDX,"^",FBPDX) 52 W !,?46,"|",!,V(1),?46,"|",!,V(3),?46,"|" W:V(14)]"" !,V(14),?46,"|" 53 W !,V(4)," ",VSTCD," ",V(6),?46,"|",!,V(2),?46,"|","AUTHORIZATION #: ",DFN,"-",FBK,!,UL,! 54 W ?49,"AUTHORIZATION REMARKS",!,?49,$E(UL,1,21) 55 D ^FBAA79A S $P(^FBAAA(DFN,1,FBK,1),"^",2)=DT,FBPG=1 Q
Note:
See TracChangeset
for help on using the changeset viewer.
