- FBNHEDAT ;AISC/GRR - ENTER/EDIT AUTHORIZATION ;9/19/2014
- ;;3.5;FEE BASIS;**103,108,139,154**;JAN 30, 1995;Build 12
- ;;Per VA Directive 6402, 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
- ; FB*3.5*139-ICD10 REMEDIATION-jlg - modify original code to process diagnosis code based on ICD version in DR string
- S DR(1,161.01,1)="@2;.065;.07;.021;S:FBAA(1)'<$$IMPDATE^FBCSV1(""10D"") Y=""@10"";.08;S:X="""" Y=101;.085;S:X="""" Y=101;.086;S Y=101;"
- S DR(1,161.01,2)="@10;N XX1;S XX1=-1;S FBDFN=DFN;S EDATE=FBAA(1);S XX1=$$ASKICD10^FBASF(""ICD DIAGNOSIS"","""","""",""Y"");S:XX1<1 Y=""@10"";.087////^S X=XX1;101;104;.097" D ^DIE
- ; End 139
- 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
- D
- . N FBX
- . S FBX=$$ADDUA^FBUTL9(162.4,FBAA78_",","Edit CNH 7078 authorization.")
- . I 'FBX W !,"Error adding record in User Audit. Please contact IRM."
- 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 GETAUTHK^FBAAUTL1
- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HFBNHEDAT 3448 printed Dec 13, 2024@01:58:57 Page 2
- FBNHEDAT ;AISC/GRR - ENTER/EDIT AUTHORIZATION ;9/19/2014
- +1 ;;3.5;FEE BASIS;**103,108,139,154**;JAN 30, 1995;Build 12
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 DO SITEP^FBAAUTL
- RD1 SET U="^"
- DO GETVET^FBAAUTL1
- if DFN=""
- GOTO END
- +1 SET FBPROG="I $P(^(0),U,3)=7"
- DO GETAUTH^FBAAUTL1
- if 'CNT!(FTP']"")!($DATA(DIRUT))
- GOTO RD1
- SET (FBOLD,FBNEW,FBERR)=""
- +2 KILL FBAUT,CNT
- SET (DA(1),D0)=DFN
- SET FBOLD=^FBAAA(DFN,1,FTP,0)
- SET DA=FTP
- SET FBAAADA=DA
- SET DIE="^FBAAA("_DFN_",1,"
- SET FBO=$PIECE(FBOLD,"^")
- SET (FB1,FBAA(2))=$PIECE(FBOLD,"^",2)
- +3 SET FBPROG=7
- DO DATES^FBAAUTL2
- SET FBAA(1)=$SELECT($GET(FBBEGDT):FBBEGDT,1:FBO)
- SET FBAA(2)=$SELECT($GET(FBENDDT):FBENDDT,1:FB1)
- DR SET DR=".01////^S X=FBAA(1);.02////^S X=FBAA(2)"
- +1 ; fb*3.5*103 add REFERRING PROVIDER (161.01,104) to DR string
- +2 ; FB*3.5*139-ICD10 REMEDIATION-jlg - modify original code to process diagnosis code based on ICD version in DR string
- +3 SET DR(1,161.01,1)="@2;.065;.07;.021;S:FBAA(1)'<$$IMPDATE^FBCSV1(""10D"") Y=""@10"";.08;S:X="""" Y=101;.085;S:X="""" Y=101;.086;S Y=101;"
- +4 SET DR(1,161.01,2)="@10;N XX1;S XX1=-1;S FBDFN=DFN;S EDATE=FBAA(1);S XX1=$$ASKICD10^FBASF(""ICD DIAGNOSIS"","""","""",""Y"");S:XX1<1 Y=""@10"";.087////^S X=XX1;101;104;.097"
- DO ^DIE
- +5 ; End 139
- +6 SET FBNEW=$SELECT('$DATA(DA):"",'$DATA(^FBAAA(DFN,1,DA,0)):"",1:^(0))
- KILL DR
- +7 IF $DATA(Y)>0
- IF FBNEW=""!(FBNEW=FBOLD)
- GOTO RD1
- +8 IF FBNEW'=FBOLD
- IF $PIECE(FBNEW,"^")>$PIECE(FBNEW,"^",2)
- SET DR=".01////^S X=FBO;.02////^S X=FB1"
- DO ^DIE
- KILL DR
- DO ER
- GOTO DR
- +9 ;
- +10 SET FBAA78=FB7078
- DO ^FBNHEDA1
- KILL FBAA78
- IF FBERR
- SET DA(1)=DFN
- SET DA=FTP
- SET DIE="^FBAAA("_DA(1)_",1,"
- SET DR=".01////^S X=FBO;.02////^S X=FB1"
- DO ^DIE
- GOTO END
- +11 ; fb*3.5*103 add the REFERRING PROVIDER (162.4,15) to the DR string; stuff with the value stored at 161.01,104
- +12 SET DIE="^FB7078("
- SET DA=FB7078
- SET FBAA78=DA
- SET DR="5;6;15////^S X=$$GET1^DIQ(161.01,FBAAADA_"",""_DFN,104,""I"")"
- IF 'DA
- WRITE !!,*7,"No 7078 on file!",!
- GOTO END
- +13 if FBOLD'=FBNEW
- DO CHANGED
- GO DO ^DIE
- +1 Begin DoDot:1
- +2 NEW FBX
- +3 SET FBX=$$ADDUA^FBUTL9(162.4,FBAA78_",","Edit CNH 7078 authorization.")
- +4 IF 'FBX
- WRITE !,"Error adding record in User Audit. Please contact IRM."
- End DoDot:1
- +5 IF $ORDER(^FBAAA(DFN,1,FBAAADA,2,0))>0
- KILL ^FB7078(FBAA78,1)
- SET ^FB7078(FBAA78,1,0)=^FBAAA(DFN,1,FBAAADA,2,0)
- FOR Z=0:0
- SET Z=$ORDER(^FBAAA(DFN,1,FBAAADA,2,Z))
- if Z'>0
- QUIT
- SET ^FB7078(FBAA78,1,Z,0)=^FBAAA(DFN,1,FBAAADA,2,Z,0)
- RD2 SET DIR(0)="Y"
- SET DIR("A")="Want to Queue 7078 for printing"
- SET DIR("B")=$SELECT(FBOLD=FBNEW:"No",1:"Yes")
- DO ^DIR
- KILL DIR
- if Y'>0
- GOTO RD1
- CHEKP78 SET FBNUM=$PIECE(FBSITE(1),"^",5)
- SET FBO=$PIECE(FBSITE(1),"^",7)
- SET FBT=$PIECE(FBSITE(1),"^",8)
- DO FBO^FBCHP78
- if $DATA(DIRUT)
- GOTO END
- SET IOP="Q"
- SET %ZIS("B")=""
- SET FB7078=FBAA78
- SET FB("SITE")=$PIECE(FBSITE(1),"^",3)
- WRITE !
- +1 SET VAR="FB7078^FBNUM^FBO^FBT^FB(""SITE"")"
- SET VAL=FB7078_"^"_FBNUM_"^"_FBO_"^"_FBT_"^"_FB("SITE")
- SET PGM="START^FBCHP78"
- WRITE !
- DO ZIS^FBAAUTL
- +2 ;
- END KILL 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
- +1 KILL 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
- +2 DO END^FBNHEAU1
- +3 DO GETAUTHK^FBAAUTL1
- +4 DO CLOSE^FBAAUTL
- +5 QUIT
- +6 ;
- CHANGED if $PIECE(FBOLD,"^",1)'=$PIECE(FBNEW,"^",1)
- SET DR="3////^S X=$P(FBNEW,U,1);"_DR
- +1 if $PIECE(FBOLD,"^",2)'=$PIECE(FBNEW,"^",2)
- SET DR="4////^S X=$P(FBNEW,U,2);"_DR
- +2 QUIT
- +3 ;
- ER WRITE !,*7,"From Date cannot be greater than the To Date.",!
- +1 QUIT
- +2 ;
- ER1 WRITE !,*7,"This patient has movements after the authorization to date. You must",!,"edit the patient's movements first.",!
- +1 QUIT