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

DGA4005 ;ALB/MRL - AMIS 401-420 REPORT GENERATION ;01 JAN 1988@2300
 ;;5.3;Registration;;Aug 13, 1993
EN S DGPR=0 D SET
 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:"")
EN1 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)=""
 F I=0:0 S I=$O(^UTILITY($J,"DGSEG",I)) Q:'I  D S
 ;Q:DGPR <-- REMOVED
 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
 K DGFL G QUIT^DGA4002
S D DV^DGA4001,H
 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
 D END Q
WR 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),"|"
 S DGXI=$X W $C(13),$E(DGL,1,DGXI) Q
H ;
 S Y=DGA X ^DD("DD") W @IOF,!,"AMIS SEGMENTS 401-420, ",Y,", '",$P(DGDV,"^",2),"' DIVISION",!,DGL1
 W !?5,"Segment Number ===>",?30,"|"
 F DGXI=401:1:420 I $$OKDATE(DGXI) W " ",DGXI,"|"
 S DGXI=$X-1 W $C(13),$E(DGL,1,DGXI)
 W !?30,"|"
 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 "|"
 ;SC | SC | SC | SC | SC | SC | SC | SC | SC | SC | SC | SC | POW| AO/| WWI| VA |Medi| NSC| NSC| NSC|"
 W !?5,"Data Element",?30,"|"
 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 "|"
 ;100%| 90%| 80%| 70%| 60%| 50%| 40%| 30%| 20%| 10%| 0% | Oth|    | IR | Vet|Pens|caid| 'A'| 'B'| 'C'|"
 S DGXI=$X W $C(13),$E(DGL,1,DGXI)
 W !,DGL1 Q
END S DGXI=$X W $C(13),$E(DGL,1,DGXI)
 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."
 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."
 W !?55,"With the exception of Segment 420, BLOCKS 39-40 should always be ZERO.",!
 I $D(DGFL(+DGDV)) W !!,"***","Not able to generate AMIS - Data segments are out of balance for:",!
 I $D(DGFL(+DGDV)) F X=0:0 S X=$O(DGUB(X)) Q:'X  W X_$S($O(DGUB(X)):",",1:"")
 W !,DGL1
 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
SET D H^DGUTL S Y=DGTIME X ^DD("DD") S DGWHEN="Report Printed: "_Y,(DGL,DGL1,DGEN)=""
 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
 S $P(DGL,"_",(DGWIDTH-1))="",$P(DGL1,"=",DGWIDTH)="" K ^UTILITY($J,"DGSEG") Q
REP ;Reprint
 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)
 G EN1
REP1 G EN
SAV 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
 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
 K DGSEG,DGDIV,DGMYR
 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")
 G EN
SAV1 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
 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
 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
 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)=""
 D H^DGUTL I $P(^DG(391.1,DGI,"D",DGI1,"MY",DGA,0),"^",2)="" S $P(^(0),"^",2)=DUZ,$P(^(0),"^",3)=DGTIME
 S $P(^DG(391.1,DGI,"D",DGI1,"MY",DGA,0),"^",4)=DUZ,$P(^(0),"^",5)=DGTIME
 W:IO=DGDEV "." S ^DG(391.1,DGI,"D",DGI1,"MY",DGA,"A1")=DGN,DGN="" Q
OKDATE(SEGMENT) ;
 ;NEEDS DGA TO BE DEFINED
 ;INACTDT=AMIS SEGMENT INACTIVATION DATE
 N INACTDT,DGFL
 S INACTDT=$S(('$D(^DG(391.1,SEGMENT,0))):0,1:$P(^DG(391.1,SEGMENT,0),"^",3))
 S DGFL=0 I (INACTDT']"")!(INACTDT>DGA) S DGFL=1
 Q DGFL