source: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGA4005.m@ 1800

Last change on this file since 1800 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 4.7 KB
RevLine 
[613]1DGA4005 ;ALB/MRL - AMIS 401-420 REPORT GENERATION ;01 JAN 1988@2300
2 ;;5.3;Registration;;Aug 13, 1993
3EN S DGPR=0 D SET
4 F I=401:1:420 I $$OKDATE(I) F I1=0:0 S I1=$O(^DG(391.1,I,"D",I1)) Q:'I1 S DGDD(I1)="" S X=$S($D(^DG(391.1,I,"D",I1,"MY",DGA,"A1")):^("A1"),1:""),^UTILITY($J,"DGSEG",I1,I)=X S:'DGEN DGEN=$S($D(^DG(391.1,I,"D",I1,"MY",DGA,0)):^(0),1:"")
5EN1 F I=401:1:420 I $$OKDATE(I) F I1=0:0 S I1=$O(DGDD(I1)) Q:'I1 I '$D(^UTILITY($J,"DGSEG",I1,I)) S ^(I)=""
6 F I=0:0 S I=$O(^UTILITY($J,"DGSEG",I)) Q:'I D S
7 ;Q:DGPR <-- REMOVED
8 I $D(^UTILITY($J,"DGSEGP")) K %,D,D1,DGDD,DGDV,DGEN,DGPR,DGTIME,DGWHEN,DIC,I,I1,N,X,Y,^UTILITY($J,"DGSEG") D ^DGA4006
9 K DGFL G QUIT^DGA4002
10S D DV^DGA4001,H
11 F D=1:1:40 S D1=$S($D(^DD(391.12,D,0)):$P(^(0),"^",1),1:"UNKNOWN ELEMENT") W !,$S(D<10:"0"_D,1:D)_")",?4,$E(D1,1,25),?30,"|" D WR
12 D END Q
13WR F N=401:1:420 I $$OKDATE(N) S X=$S($D(^UTILITY($J,"DGSEG",I,N)):+$P(^(N),"^",D),1:0) S:'X X=" " W ?$X,$J(X,4),"|"
14 S DGXI=$X W $C(13),$E(DGL,1,DGXI) Q
15H ;
16 S Y=DGA X ^DD("DD") W @IOF,!,"AMIS SEGMENTS 401-420, ",Y,", '",$P(DGDV,"^",2),"' DIVISION",!,DGL1
17 W !?5,"Segment Number ===>",?30,"|"
18 F DGXI=401:1:420 I $$OKDATE(DGXI) W " ",DGXI,"|"
19 S DGXI=$X-1 W $C(13),$E(DGL,1,DGXI)
20 W !?30,"|"
21 F DGXI=401:1:420 I $$OKDATE(DGXI) S DGLAB=$P("SC^SC^SC^SC^SC^SC^SC^SC^SC^SC^SC^SC^POW^AO/^WWI^VA^Medi^NSC^NSC^NSC","^",(DGXI-400)) W:($L(DGLAB)<4) " " W DGLAB W:($L(DGLAB)<3) " " W "|"
22 ;SC | SC | SC | SC | SC | SC | SC | SC | SC | SC | SC | SC | POW| AO/| WWI| VA |Medi| NSC| NSC| NSC|"
23 W !?5,"Data Element",?30,"|"
24 F DGXI=401:1:420 I $$OKDATE(DGXI) S DGLAB=$P("100%^90%^80%^70%^60%^50%^40%^30%^20%^10%^0%^Oth^ ^IR^Vet^Pens^caid^'A'^'B'^ 'C'",U,(DGXI-400)) W:($L(DGLAB)<4) " " W DGLAB W:($L(DGLAB)<3) " " W "|"
25 ;100%| 90%| 80%| 70%| 60%| 50%| 40%| 30%| 20%| 10%| 0% | Oth| | IR | Vet|Pens|caid| 'A'| 'B'| 'C'|"
26 S DGXI=$X W $C(13),$E(DGL,1,DGXI)
27 W !,DGL1 Q
28END S DGXI=$X W $C(13),$E(DGL,1,DGXI)
29 W !,DGL1,!,"FOR EACH SEGMENT BLOCKS SHOULD BALANCE AS FOLLOWS: ",?55,"Sum of BLOCKS 02-15 plus 22-25 plus 30-33 plus 38-40 = BLOCK 01."
30 W !?55,"Sum of BLOCKS 11-15 = Sum of BLOCKS 16-19.",!?55,"Sum of BLOCKS 11-15 = Sum of BLOCKS 20-21.",!?55,"Sum of BLOCKS 22-25 = Sum of BLOCKS 26-29.",!?55,"Sum of BLOCKS 30-33 = Sum of BLOCKS 34-37."
31 W !?55,"With the exception of Segment 420, BLOCKS 39-40 should always be ZERO.",!
32 I $D(DGFL(+DGDV)) W !!,"***","Not able to generate AMIS - Data segments are out of balance for:",!
33 I $D(DGFL(+DGDV)) F X=0:0 S X=$O(DGUB(X)) Q:'X W X_$S($O(DGUB(X)):",",1:"")
34 W !,DGL1
35 S Y=$P(DGEN,"^",5) X ^DD("DD") W !,"Totals last generated on '",Y,"' by '",$S($D(^VA(200,+$P(DGEN,"^",4),0)):$P(^(0),"^",1),1:"UNKNOWN USER"),"'.",?(127-$L(DGWHEN)-1),DGWHEN,! Q
36SET D H^DGUTL S Y=DGTIME X ^DD("DD") S DGWHEN="Report Printed: "_Y,(DGL,DGL1,DGEN)=""
37 S DGWIDTH=132 F DGII=401:1:420 S X=$P(^DG(391.1,DGII,0),U,3) I (X>0)&(X<DGA) S DGWIDTH=DGWIDTH-5
38 S $P(DGL,"_",(DGWIDTH-1))="",$P(DGL1,"=",DGWIDTH)="" K ^UTILITY($J,"DGSEG") Q
39REP ;Reprint
40 D SET S I1=+DGPR,DGDD(I1)="" F I=401:1:420 S X=$S($D(^DG(391.1,I,"D",I1,"MY",DGA,"A1")):^("A1"),1:""),^UTILITY($J,"DGSEG",I1,I)=X I 'DGEN,$D(^DG(391.1,I,"D",I1,"MY",DGA,0)) S DGEN=^(0)
41 G EN1
42REP1 G EN
43SAV S DGFLG=0 F DGI=0:0 S DGI=$O(^UTILITY($J,"DGSEG",DGI)) Q:'DGI F DGI1=0:0 S DGI1=$O(^UTILITY($J,"DGSEG",DGI,DGI1)) Q:'DGI1 S DGN=^(DGI1),DGFLG=0 D ^DGA4007,SAV1
44 I DGCODFLG=1 F DGDIV=0:0 S DGDIV=$O(DGDIV(DGDIV)) Q:'DGDIV I DGDIV(DGDIV) S DGSEG=401,DGMYR=DGA D QUE^DGGECSA
45 K DGSEG,DGDIV,DGMYR
46 K DA,DFN,DFN1,DG,DGBLK,DGDATA,DGDATA1,DGDIV,DGDV,DGI,DGI1,DGN,DGN1,DGREG,DGSEG,DGSEGR,DGDATE,DGTIME,DGX,DGX1,DGX2,DGX3,DGXXXD,DGZ,DGZ1,DGZ2,DIC,DINUM,I,J,X,X1,X2,^UTILITY($J,"DGSEG"),^("DGDIS")
47 G EN
48SAV1 I '$D(^DG(391.1,DGI,0)) S DIC="^DG(391.1,",(X,DA,DINUM)=DGI,DIC(0)="L" K DD,DO D FILE^DICN
49 S:'$D(^DG(391.1,DGI,"D",0)) ^(0)="^391.11P^^" I '$D(^DG(391.1,DGI,"D",DGI1,0)) S DIC="^DG(391.1,"_DGI_",""D"",",DA(1)=DGI,(X,DA,DINUM)=DGI1,DIC(0)="L" K DD,DO D FILE^DICN
50 S:'$D(^DG(391.1,DGI,"D",DGI1,"MY",0)) ^(0)="^391.12D^^" I '$D(^DG(391.1,DGI,"D",DGI1,"MY",DGA,0)) S DIC="^DG(391.1,"_DGI_",""D"","_DGI1_",""MY"",",DA(2)=DGI,DA(1)=DGI1,(X,DA,DINUM)=DGA,DIC(0)="L" K DD,DO D FILE^DICN
51 I $D(DGFLG) S $P(^DG(391.1,DGI,"D",DGI1,"MY",DGA,0),"^",6)=$S(DGFLG:1,1:0),DGDIV(DGI1)=DGFLG I 'DGFLG S DGFL(DGI1)=""
52 D H^DGUTL I $P(^DG(391.1,DGI,"D",DGI1,"MY",DGA,0),"^",2)="" S $P(^(0),"^",2)=DUZ,$P(^(0),"^",3)=DGTIME
53 S $P(^DG(391.1,DGI,"D",DGI1,"MY",DGA,0),"^",4)=DUZ,$P(^(0),"^",5)=DGTIME
54 W:IO=DGDEV "." S ^DG(391.1,DGI,"D",DGI1,"MY",DGA,"A1")=DGN,DGN="" Q
55OKDATE(SEGMENT) ;
56 ;NEEDS DGA TO BE DEFINED
57 ;INACTDT=AMIS SEGMENT INACTIVATION DATE
58 N INACTDT,DGFL
59 S INACTDT=$S(('$D(^DG(391.1,SEGMENT,0))):0,1:$P(^DG(391.1,SEGMENT,0),"^",3))
60 S DGFL=0 I (INACTDT']"")!(INACTDT>DGA) S DGFL=1
61 Q DGFL
Note: See TracBrowser for help on using the repository browser.