Ignore:
Timestamp:
Dec 4, 2009, 8:26:01 PM (14 years ago)
Author:
George Lilly
Message:

WorldVistAEHR overlayed on FOIAVistA

Location:
FOIAVistA/tag/r
Files:
1 edited
1 copied

Legend:

Unmodified
Added
Removed

  • FOIAVistA/tag/r/INTEGRATED_BILLING-IB-PRQ--IBD--IBQ--PRQS/IBXX14.m

    r628 r636  
    1 IBXX14 ; COMPILED XREF FOR FILE #399.30416 ; 07/22/08
     1IBXX14 ; COMPILED XREF FOR FILE #399 ; 12/27/07
    22 ;
    3  S DA(2)=DA(1) S DA(1)=0 S DA=0
    4 A1 ;
    5  I $D(DIKILL) K DIKLM S:DIKM1=2 DIKLM=1 S:DIKM1'=2&'$G(DIKPUSH(2)) DIKPUSH(2)=1,DA(2)=DA(1),DA(1)=DA,DA=0 G @DIKM1
    6 A S DA(1)=$O(^DGCR(399,DA(2),"CP",DA(1))) I DA(1)'>0 S DA(1)=0 G END
    7 1 ;
    8 B S DA=$O(^DGCR(399,DA(2),"CP",DA(1),"MOD",DA)) I DA'>0 S DA=0 Q:DIKM1=1  G A
    9 2 ;
    10  S DIKZ(0)=$G(^DGCR(399,DA(2),"CP",DA(1),"MOD",DA,0))
     3 S DIKZK=1
     4 S DIKZ(0)=$G(^DGCR(399,DA,0))
     5 S X=$P(DIKZ(0),U,1)
     6 I X'="" S ^DGCR(399,"B",$E(X,1,30),DA)=""
     7 S X=$P(DIKZ(0),U,1)
     8 I X'="" D
     9 .N DIK,DIV,DIU,DIN
     10 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,1)="" I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,1),X=X S DIU=X K Y S X=DIV S X=DT X ^DD(399,.01,1,3,1.4)
     11 S X=$P(DIKZ(0),U,1)
     12 I X'="" D
     13 .N DIK,DIV,DIU,DIN
     14 .X ^DD(399,.01,1,4,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=$S(($D(DUZ)#2):DUZ,1:"") X ^DD(399,.01,1,4,1.4)
     15 S X=$P(DIKZ(0),U,1)
     16 I X'="" D
     17 .N DIK,DIV,DIU,DIN
     18 .X ^DD(399,.01,1,5,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,14),X=X S DIU=X K Y S X=DIV S X=$S($D(^IBE(350.9,1,1)):$P(^(1),U,6),1:"") X ^DD(399,.01,1,5,1.4)
     19 S X=$P(DIKZ(0),U,1)
     20 I X'="" D
     21 .N DIK,DIV,DIU,DIN
     22 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,13),X=X S DIU=X K Y S X=DIV S X=1 S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,13)=DIV,DIH=399,DIG=.13 D ^DICR
     23 S X=$P(DIKZ(0),U,1)
     24 I X'="" D
     25 .N DIK,DIV,DIU,DIN
     26 .X ^DD(399,.01,1,7,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,19),X=X S DIU=X K Y S X=DIV S X=3 S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,19)=DIV,DIH=399,DIG=.19 D ^DICR
     27 S DIKZ(0)=$G(^DGCR(399,DA,0))
    1128 S X=$P(DIKZ(0),U,2)
    12  I X'="" K ^DGCR(399,DA(2),"CP",DA(1),"MOD","C",$E(X,1,30),DA)
    13  S X=$P(DIKZ(0),U,1)
    14  I X'="" K ^DGCR(399,DA(2),"CP",DA(1),"MOD","B",$E(X,1,30),DA)
    15  G:'$D(DIKLM) B Q:$D(DIKILL)
    16 END Q
     29 I X'="" S ^DGCR(399,"C",$E(X,1,30),DA)=""
     30 S X=$P(DIKZ(0),U,3)
     31 I X'="" S ^DGCR(399,"D",$E(X,1,30),DA)=""
     32 S X=$P(DIKZ(0),U,3)
     33 I X'="" S IBN=$P(^DGCR(399,DA,0),"^",2) S:$D(IBN) ^DGCR(399,"APDT",IBN,DA,9999999-X)="" K IBN
     34 S X=$P(DIKZ(0),U,3)
     35 I X'="" S ^DGCR(399,"ABNDT",DA,9999999-X)=""
     36 S X=$P(DIKZ(0),U,4)
     37 I X'="" D
     38 .N DIK,DIV,DIU,DIN
     39 .X ^DD(399,.04,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,24),X=X S DIU=X K Y S X=DIV S X=DIV,X=X S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,24)=DIV,DIH=399,DIG=.24 D ^DICR
     40 S DIKZ(0)=$G(^DGCR(399,DA,0))
     41 S X=$P(DIKZ(0),U,5)
     42 I X'="" S ^DGCR(399,"ABT",$E(X,1,30),DA)=""
     43 S X=$P(DIKZ(0),U,5)
     44 I X'="" D
     45 .N DIK,DIV,DIU,DIN
     46 .X ^DD(399,.05,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,25),X=X S DIU=X K Y S X=DIV S X=$$TRIG05^IBCU4(X,D0) S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,25)=DIV,DIH=399,DIG=.25 D ^DICR
     47 S DIKZ(0)=$G(^DGCR(399,DA,0))
     48 S X=$P(DIKZ(0),U,6)
     49 I X'="" D
     50 .N DIK,DIV,DIU,DIN
     51 .X ^DD(399,.06,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,26),X=X S DIU=X K Y S X=DIV S X=DIV,X=X S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,26)=DIV,DIH=399,DIG=.26 D ^DICR
     52 S DIKZ(0)=$G(^DGCR(399,DA,0))
     53 S X=$P(DIKZ(0),U,7)
     54 I X'="" D
     55 .N DIK,DIV,DIU,DIN
     56 .X ^DD(399,.07,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,6),X=X S DIU=X K Y S X=DIV S X=1 X ^DD(399,.07,1,1,1.4)
     57 S X=$P(DIKZ(0),U,7)
     58 I X'="" D
     59 .N DIK,DIV,DIU,DIN
     60 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,11),X=X S DIU=X K Y S X=DIV S X=$P(^DGCR(399.3,$P(^DGCR(399,DA,0),U,7),0),U,7) X ^DD(399,.07,1,2,1.4)
     61 S X=$P(DIKZ(0),U,7)
     62 I X'="" S ^DGCR(399,"AD",$E(X,1,30),DA)=""
     63 S DIKZ(0)=$G(^DGCR(399,DA,0))
     64 S X=$P(DIKZ(0),U,8)
     65 I X'="" D
     66 .N DIK,DIV,DIU,DIN
     67 .X ^DD(399,.08,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,9),X=X S DIU=X K Y S X=DIV S X=2 X ^DD(399,.08,1,1,1.4)
     68 S X=$P(DIKZ(0),U,8)
     69 I X'="" D
     70 .N DIK,DIV,DIU,DIN
     71 .X ^DD(399,.08,1,2,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,8),X=X S DIU=X K Y S X=DIV S X=2 X ^DD(399,.08,1,2,1.4)
     72 S X=$P(DIKZ(0),U,8)
     73 I X'="" D
     74 .N DIK,DIV,DIU,DIN
     75 .X ^DD(399,.08,1,4,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y S X=DIV D DIS^IBCU S X=X X ^DD(399,.08,1,4,1.4)
     76 S X=$P(DIKZ(0),U,8)
     77 I X'="" S ^DGCR(399,"APTF",$E(X,1,30),DA)=""
     78 S X=$P(DIKZ(0),U,8)
     79 I X'="" D
     80 .N DIK,DIV,DIU,DIN
     81 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X I $P(^DGCR(399,DA,0),U,5)<3 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"U")):^("U"),1:"") S X=$P(Y(1),U,15),X=X S DIU=X K Y S X=DIV S X=+$$LOS1^IBCU64(DA) X ^DD(399,.08,1,6,1.4)
     82 S DIKZ(0)=$G(^DGCR(399,DA,0))
     83 S X=$P(DIKZ(0),U,11)
     84 I X'="" D
     85 .N DIK,DIV,DIU,DIN
     86 .X ^DD(399,.11,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"M")):^("M"),1:"") S X=$P(Y(1),U,12),X=X S DIU=X K Y S X=DIV D EN1^IBCU5 X ^DD(399,.11,1,1,1.4)
     87 S X=$P(DIKZ(0),U,11)
     88 I X'="" D EN^IBCU5
     89 S X=$P(DIKZ(0),U,11)
     90 I X'="" S DGRVRCAL=1
     91 S X=$P(DIKZ(0),U,11)
     92 I X'="" D
     93 .N DIK,DIV,DIU,DIN
     94 .X ^DD(399,.11,1,4,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,21),X=X S DIU=X K Y X ^DD(399,.11,1,4,1.1) X ^DD(399,.11,1,4,1.4)
     95 S DIKZ(0)=$G(^DGCR(399,DA,0))
     96 S X=$P(DIKZ(0),U,13)
     97 I X'="" D
     98 .N DIK,DIV,DIU,DIN
     99 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,14),X=X S DIU=X K Y S X=DIV S X=DT X ^DD(399,.13,1,1,1.4)
     100 S X=$P(DIKZ(0),U,13)
     101 I X'="" I X>0,X<3,$P(^DGCR(399,DA,0),U,2) S ^DGCR(399,"AOP",$P(^(0),U,2),DA)=""
     102 S X=$P(DIKZ(0),U,13)
     103 I X'="" I +X=3 S ^DGCR(399,"AST",+X,DA)=""
     104 S X=$P(DIKZ(0),U,13)
     105 I X'="" D
     106 .N DIK,DIV,DIU,DIN
     107 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=Y(0),X=X S X=X=2 I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"TX")):^("TX"),1:"") S X=$P(Y(1),U,5),X=X S DIU=X K Y S X=DIV S X="1N" X ^DD(399,.13,1,4,1.4)
     108 S DIKZ(0)=$G(^DGCR(399,DA,0))
     109 S X=$P(DIKZ(0),U,14)
     110 I X'="" D BC^IBJVDEQ
     111 S X=$P(DIKZ(0),U,17)
     112 I X'="" S ^DGCR(399,"AC",$E(X,1,30),DA)=""
     113 S X=$P(DIKZ(0),U,19)
     114 I X'="" D
     115 .N DIK,DIV,DIU,DIN
     116 .X ^DD(399,.19,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,0)):^(0),1:"") S X=$P(Y(1),U,9),X=X S DIU=X K Y S X=DIV S X=5 S DIH=$G(^DGCR(399,DIV(0),0)),DIV=X S $P(^(0),U,9)=DIV,DIH=399,DIG=.09 D ^DICR
     117 S X=$P(DIKZ(0),U,19)
     118 I X'="" S DGRVRCAL=1
     119 S X=$P(DIKZ(0),U,19)
     120 I X'="" D ALLID^IBCEP3(DA,.19,1)
     121 S X=$P(DIKZ(0),U,19)
     122 I X'="" D BILLPNS^IBCU(DA)
     123 S X=$P(DIKZ(0),U,19)
     124 I X'="" D ATTREND^IBCU1(DA,"","")
     125 S DIKZ(0)=$G(^DGCR(399,DA,0))
     126 S X=$P(DIKZ(0),U,20)
     127 I X'="" D
     128 .N DIK,DIV,DIU,DIN
     129 .X ^DD(399,.2,1,1,1.3) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"S")):^("S"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=.5 X ^DD(399,.2,1,1,1.4)
     130 S DIKZ(0)=$G(^DGCR(399,DA,0))
     131 S X=$P(DIKZ(0),U,21)
     132 I X'="" D
     133 .N DIK,DIV,DIU,DIN
     134 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"MP")):^("MP"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=$$BPP^IBCNS2(DA) X ^DD(399,.21,1,1,1.4)
     135 S X=$P(DIKZ(0),U,21)
     136 I X'="" D
     137 .N DIK,DIV,DIU,DIN
     138 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=('$$REQMRA^IBEFUNC(DA)&$$NEEDMRA^IBEFUNC(DA)) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"TX")):^("TX"),1:"") S X=$P(Y(1),U,5),X=X S DIU=X K Y S X=DIV S X=0 X ^DD(399,.21,1,2,1.4)
     139 S X=$P(DIKZ(0),U,21)
     140 I X'="" D
     141 .N DIK,DIV,DIU,DIN
     142 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(0)=X S X=$S($$WNRBILL^IBEFUNC(DA,X):1,1:0) I X S X=DIV S Y(1)=$S($D(^DGCR(399,D0,"TX")):^("TX"),1:"") S X=$P(Y(1),U,8),X=X S DIU=X K Y S X="" X ^DD(399,.21,1,3,1.4)
     143 S DIKZ(0)=$G(^DGCR(399,DA,0))
     144 S X=$P(DIKZ(0),U,22)
     145 I X'="" D
     146 .N DIK,DIV,DIU,DIN
     147 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,2),X=X S DIU=X K Y S X=DIV S X=$$PRVNUM^IBCU(DA,"",1) X ^DD(399,.22,1,1,1.4)
     148 S X=$P(DIKZ(0),U,22)
     149 I X'="" D
     150 .N DIK,DIV,DIU,DIN
     151 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,3),X=X S DIU=X K Y S X=DIV S X=$$PRVNUM^IBCU(DA,"",2) X ^DD(399,.22,1,2,1.4)
     152 S X=$P(DIKZ(0),U,22)
     153 I X'="" D
     154 .N DIK,DIV,DIU,DIN
     155 .K DIV S DIV=X,D0=DA,DIV(0)=D0 S Y(1)=$S($D(^DGCR(399,D0,"M1")):^("M1"),1:"") S X=$P(Y(1),U,4),X=X S DIU=X K Y S X=DIV S X=$$PRVNUM^IBCU(DA,"",3) X ^DD(399,.22,1,3,1.4)
     156 S X=$P(DIKZ(0),U,22)
     157END G ^IBXX15
Note: See TracChangeset for help on using the changeset viewer.