- FBAA79 ;AISC/GRR - PRINT FORM 7079 REQUEST FOR OUTPATIENT MEDICAL SERVICES ;6/5/2009
- ;;3.5;FEE BASIS;**12,23,101,103,108,139**;JAN 30, 1995;Build 127
- ;;Per VA Directive 6402, this routine should not be modified.
- ;
- ; Reference to API $$CODEC^ICDEX supported by ICR #5747
- ;
- 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 GETAUTHK^FBAAUTL1
- 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)),"^")
- ;DEM;139 ICD-10 Project - Set variable VDX=ICD DIAGNOSIS code from ICD DIAGNOSIS FILE (#80).
- D:$P($G(^FBAAA(DFN,1,FBK,"C")),"^",2) ;ICD DIAGNOSIS field (POINTER TO ICD DIAGNOSIS FILE (#80)).
- . S VDX=$P($G(^FBAAA(DFN,1,FBK,"C")),"^",2) ;ICD DIAGNOSIS field (POINTER TO ICD DIAGNOSIS FILE (#80)).
- . S VDX=$$CODEC^ICDEX(80,VDX) ;Diagnosis Code from an IEN.
- . I +VDX<0 S VDX="" Q ; -1 ^ message on error.
- . Q
- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBAA79 4979 printed Jan 18, 2025@02:56:03 Page 2
- FBAA79 ;AISC/GRR - PRINT FORM 7079 REQUEST FOR OUTPATIENT MEDICAL SERVICES ;6/5/2009
- +1 ;;3.5;FEE BASIS;**12,23,101,103,108,139**;JAN 30, 1995;Build 127
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;
- +4 ; Reference to API $$CODEC^ICDEX supported by ICR #5747
- +5 ;
- +6 WRITE !,"Print 7079's for: "
- DO DT^DICRW
- DO DATE^FBAAUTL
- if FBPOP
- GOTO END
- DO SITEP^FBAAUTL
- if FBPOP
- GOTO END
- +7 IF '$DATA(^FBAAA("AF",2))
- WRITE !!,*7,"There are no 7079's to be printed!",!
- GOTO END
- +8 SET FBAASCR=""
- RDHOW WRITE !
- SET DIR("A")="Want only those that have not yet been printed"
- SET DIR("B")="Yes"
- SET DIR(0)="Y"
- DO ^DIR
- KILL DIR
- if $DATA(DIRUT)
- GOTO END
- if Y
- SET FBAASCR="Y"
- +1 DO OUTPUT^FBAAS79
- +2 SET VAR="BEGDATE^ENDDATE^FBAASCR"
- SET VAL=BEGDATE_"^"_ENDDATE_"^"_FBAASCR
- SET PGM="START^FBAA79"
- SET IOP="Q"
- DO ZIS^FBAAUTL
- if FBPOP
- GOTO END
- START DO SITEP^FBAAUTL
- if FBPOP
- GOTO END
- +1 SET UL=""
- SET ULL="----------"
- SET FBPG=0
- FOR Z=1:1:12
- SET UL=UL_ULL
- +2 USE IO
- SET FBAASCR=$SELECT(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")
- +3 SET FBJ=BEGDATE-.001
- SET (DFN,FBK)=0
- FOR ZZ=0:0
- SET FBJ=$ORDER(^FBAAA("AF",2,FBJ))
- if FBJ'>0!(FBJ>ENDDATE)
- QUIT
- FOR
- SET DFN=$ORDER(^FBAAA("AF",2,FBJ,DFN))
- if DFN'>0
- QUIT
- FOR
- SET FBK=$ORDER(^FBAAA("AF",2,FBJ,DFN,FBK))
- if FBK'>0
- QUIT
- XECUTE FBAASCR
- IF $TEST
- DO GOT
- END KILL 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
- +1 KILL 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
- +2 DO GETAUTHK^FBAAUTL1
- +3 DO CLOSE^FBAAUTL
- QUIT
- +4 QUIT
- +5 ;
- +6 ; Utilize new API for Name Standardization
- +7 ;
- GOT if '$DATA(^DPT(DFN,0))
- QUIT
- +1 SET Y(0)=^DPT(DFN,0)
- +2 Begin DoDot:1
- +3 NEW FBNAMES
- +4 SET FBNAMES("FILE")=2
- SET FBNAMES("IENS")=DFN_","
- SET FBNAMES("FIELD")=.01
- +5 SET NAME=$$NAMEFMT^XLFNAME(.FBNAMES)
- End DoDot:1
- +6 SET SEX=$PIECE(Y(0),U,2)
- +7 SET SSN=$TRANSLATE($$SSNL4^FBAAUTL($$SSN^FBAAUTL(DFN)),"-","")
- SET YOB=$SELECT($PIECE(Y(0),U,3)]"":$EXTRACT($PIECE(Y(0),U,3),1,3)+1700,1:"")
- SET POS=$SELECT($DATA(^DPT(DFN,.32)):$PIECE(^(.32),"^",3),1:"")
- SET POS=$SELECT(POS]"":$PIECE(^DIC(21,POS,0),"^",3),1:"")
- +8 FOR I=1:1:7
- SET FBI(I)=""
- +9 IF $DATA(^DPT(DFN,.11))
- FOR I=1:1:7
- SET FBI(I)=$PIECE(^(.11),"^",I)
- +10 SET POW=$PIECE($GET(^DPT(DFN,.52)),"^",5)
- +11 if '$DATA(^FBAAA(DFN,1,FBK))
- QUIT
- SET Y(0)=^(FBK,0)
- SET VFROM=$PIECE(Y(0),"^",1)
- SET VTO=$PIECE(Y(0),"^",2)
- SET VFN=$PIECE(Y(0),"^",4)
- IF $SELECT($PIECE(Y(0),"^",3)=6:1,$PIECE(Y(0),"^",3)=7:1,1:"")
- QUIT
- +12 SET VDX=$PIECE(Y(0),"^",8)
- SET FBPATT=$PIECE(Y(0),"^",18)
- SET POV=$$EXTPV^FBAAUTL5($PIECE(Y(0),"^",7))
- SET CODE=$PIECE(Y(0),"^",13)
- SET PIDC=$PIECE(Y(0),"^",12)
- SET REF=$PIECE(Y(0),"^",21)
- +13 SET NOV=$PIECE($GET(^FBAAA(DFN,1,FBK,1)),"^")
- +14 ;DEM;139 ICD-10 Project - Set variable VDX=ICD DIAGNOSIS code from ICD DIAGNOSIS FILE (#80).
- +15 ;ICD DIAGNOSIS field (POINTER TO ICD DIAGNOSIS FILE (#80)).
- if $PIECE($GET(^FBAAA(DFN,1,FBK,"C")),"^",2)
- Begin DoDot:1
- +16 ;ICD DIAGNOSIS field (POINTER TO ICD DIAGNOSIS FILE (#80)).
- SET VDX=$PIECE($GET(^FBAAA(DFN,1,FBK,"C")),"^",2)
- +17 ;Diagnosis Code from an IEN.
- SET VDX=$$CODEC^ICDEX(80,VDX)
- +18 ; -1 ^ message on error.
- IF +VDX<0
- SET VDX=""
- QUIT
- +19 QUIT
- End DoDot:1
- +20 SET FBDX=$GET(^FBAAA(DFN,1,FBK,3))
- +21 SET FBIDC=$PIECE($GET(^FBAAA(DFN,4)),"^")
- +22 SET STATCD=FBI(5)
- SET CC=FBI(7)
- FOR V=1:1:14
- SET V(V)=""
- +23 SET CC=$SELECT(CC']"":"",$DATA(^DIC(5,+STATCD,1,CC,0)):$PIECE(^(0),"^",3),1:"")
- +24 SET Y(0)=$SELECT(VFN']"":"",'$DATA(^FBAAV(VFN,0)):"",$DATA(^FBAAV(VFN,0)):^(0),1:"")
- if $SELECT(VFN']""
- GOTO OVR
- +25 FOR V=2,1,3,14,4,5,6,10
- SET V(V)=$PIECE(Y(0),"^",V)
- OVR FOR S=1:1:9
- SET FBS(S)=$PIECE(FBSITE(0),"^",S)
- +1 SET VSTCD=$SELECT(V(5)']"":" ",$DATA(^DIC(5,V(5),0)):$PIECE(^(0),"^",2),1:" ")
- SET SSTCD=$SELECT(FBS(5)']"":" ",$DATA(^DIC(5,+FBS(5),0)):$PIECE(^(0),"^",2),1:" ")
- SET PSTCD=$SELECT(FBI(5)']"":" ",$DATA(^DIC(5,+FBI(5),0)):$PIECE(^(0),"^",2),1:" ")
- +2 if FBPG
- WRITE @IOF
- WRITE 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
- SET FBREM=0
- SET FBOUT=0
- +3 ;
- +4 WRITE !,"(1) Veterans Name",?31,"|(2) ID Number | Period of Validity",!,?31,"|",?46,"|"
- +5 WRITE !,NAME,?31,"|",?32,SSN,?46,"|"," FROM: ",$$FMTE^XLFDT(VFROM)," TO: ",$$FMTE^XLFDT(VTO),!,UL
- +6 WRITE !,"(3) ADDRESS",?31,"|DATE OF ISSUE",?46,"| CONDITIONS FOR WHICH SERVICES ARE REQUESTED (DESCRIPTION OF DISABILITY)",!,?31,"|",?46,"|"
- +7 WRITE !,FBI(1),?31,"|",?33,$$FMTE^XLFDT(FBJ),?46,"|"," ",VDX
- SET FBPDX=0
- +8 IF FBI(2)]""
- WRITE !,FBI(2),?31,"|",?46,"|"," "
- SET FBPDX=FBPDX+1
- WRITE ?48,$PIECE(FBDX,"^",FBPDX)
- +9 IF FBI(3)]""
- WRITE !,FBI(3),?31,"|",?46,"|"," "
- SET FBPDX=FBPDX+1
- WRITE ?48,$PIECE(FBDX,"^",FBPDX)
- +10 WRITE !,FBI(4)," ",PSTCD," ",FBI(6),?31,"|",?46,"|"
- SET FBPDX=FBPDX+1
- WRITE ?48,$PIECE(FBDX,"^",FBPDX),!,$EXTRACT(UL,1,45),?46,"|"
- SET FBPDX=FBPDX+1
- WRITE ?48,$PIECE(FBDX,"^",FBPDX)
- +11 WRITE !,"Name and Address of Fee Participant",?46,"|"
- SET FBPDX=FBPDX+1
- WRITE ?48,$PIECE(FBDX,"^",FBPDX)
- +12 WRITE !,?46,"|",!,V(1),?46,"|",!,V(3),?46,"|"
- if V(14)]""
- WRITE !,V(14),?46,"|"
- +13 ; PRXM/KJH - Patch 103. Add Referring Provider and NPI to the display.
- +14 WRITE !,V(4)," ",VSTCD," ",V(6),?46,"|","REFERRING PROVIDER: "
- +15 IF REF'=""
- WRITE $$GET1^DIQ(200,REF,.01)
- +16 WRITE !,V(2),?46,"|","NPI: ",$$REFNPI^FBCH78(REF,"",1)
- +17 WRITE !,?46,"|","AUTHORIZATION #: ",DFN,"-",FBK,!,UL,!
- +18 WRITE ?49,"AUTHORIZATION REMARKS",!,?49,$EXTRACT(UL,1,21)
- +19 DO ^FBAA79A
- SET $PIECE(^FBAAA(DFN,1,FBK,1),"^",2)=DT
- SET FBPG=1
- QUIT