Changeset 623 for WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBAAAUT.m

Timestamp:

Dec 4, 2009, 12:11:15 AM (14 years ago)

Author:

George Lilly

Message:

revised back to 6/30/08 version

File:

• WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBAAAUT.m (modified) (1 diff)

WorldVistAEHR/trunk/r/FEE_BASIS-FB/FBAAAUT.m

@@ -1 @@
-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