Routine: DGA4005

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

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGA4005   4856     printed  Apr 23, 2025@18:55:05                                                                                                                                                                                                     Page 2

DGA4005   ;ALB/MRL - AMIS 401-420 REPORT GENERATION ;01 JAN 1988@2300

 +1       ;;5.3;Registration;;Aug 13, 1993

EN         SET DGPR=0

           DO SET

 +1        FOR I=401:1:420

               IF $$OKDATE(I)

                   FOR I1=0:0

                       SET I1=$ORDER(^DG(391.1,I,"D",I1))

                       if 'I1

                           QUIT

                       SET DGDD(I1)=""

                       SET X=$SELECT($DATA(^DG(391.1,I,"D",I1,"MY",DGA,"A1")):^("A1"),1:"")

                       SET ^UTILITY($JOB,"DGSEG",I1,I)=X

                       if 'DGEN

                           SET DGEN=$SELECT($DATA(^DG(391.1,I,"D",I1,"MY",DGA,0)):^(0),1:"")

EN1        FOR I=401:1:420

               IF $$OKDATE(I)

                   FOR I1=0:0

                       SET I1=$ORDER(DGDD(I1))

                       if 'I1

                           QUIT

                       IF '$DATA(^UTILITY($JOB,"DGSEG",I1,I))

                           SET ^(I)=""

 +1        FOR I=0:0

               SET I=$ORDER(^UTILITY($JOB,"DGSEG",I))

               if 'I

                   QUIT

               DO S

 +2       ;Q:DGPR <-- REMOVED

 +3        IF $DATA(^UTILITY($JOB,"DGSEGP"))

               KILL %,D,D1,DGDD,DGDV,DGEN,DGPR,DGTIME,DGWHEN,DIC,I,I1,N,X,Y,^UTILITY($JOB,"DGSEG")

               DO ^DGA4006

 +4        KILL DGFL

           GOTO QUIT^DGA4002

S          DO DV^DGA4001

           DO H

 +1        FOR D=1:1:40

               SET D1=$SELECT($DATA(^DD(391.12,D,0)):$PIECE(^(0),"^",1),1:"UNKNOWN ELEMENT")

               WRITE !,$SELECT(D<10:"0"_D,1:D)_")",?4,$EXTRACT(D1,1,25),?30,"|"

               DO WR

 +2        DO END

           QUIT

WR         FOR N=401:1:420

               IF $$OKDATE(N)

                   SET X=$SELECT($DATA(^UTILITY($JOB,"DGSEG",I,N)):+$PIECE(^(N),"^",D),1:0)

                   if 'X

                       SET X="    "

                   WRITE ?$X,$JUSTIFY(X,4),"|"

 +1        SET DGXI=$X

           WRITE $CHAR(13),$EXTRACT(DGL,1,DGXI)

           QUIT

H         ;

 +1        SET Y=DGA

           XECUTE ^DD("DD")

           WRITE @IOF,!,"AMIS SEGMENTS 401-420, ",Y,", '",$PIECE(DGDV,"^",2),"' DIVISION",!,DGL1

 +2        WRITE !?5,"Segment Number ===>",?30,"|"

 +3        FOR DGXI=401:1:420

               IF $$OKDATE(DGXI)

                   WRITE " ",DGXI,"|"

 +4        SET DGXI=$X-1

           WRITE $CHAR(13),$EXTRACT(DGL,1,DGXI)

 +5        WRITE !?30,"|"

 +6        FOR DGXI=401:1:420

               IF $$OKDATE(DGXI)

                   SET DGLAB=$PIECE("SC^SC^SC^SC^SC^SC^SC^SC^SC^SC^SC^SC^POW^AO/^WWI^VA^Medi^NSC^NSC^NSC","^",(DGXI-400))

                   if ($LENGTH(DGLAB)<4)

                       WRITE " "

                   WRITE DGLAB

                   if ($LENGTH(DGLAB)<3)

                       WRITE " "

                   WRITE "|"

 +7       ;SC | SC | SC | SC | SC | SC | SC | SC | SC | SC | SC | SC | POW| AO/| WWI| VA |Medi| NSC| NSC| NSC|"

 +8        WRITE !?5,"Data Element",?30,"|"

 +9        FOR DGXI=401:1:420

               IF $$OKDATE(DGXI)

                   SET DGLAB=$PIECE("100%^90%^80%^70%^60%^50%^40%^30%^20%^10%^0%^Oth^   ^IR^Vet^Pens^caid^'A'^'B'^ 'C'",U,(DGXI-400))

                   if ($LENGTH(DGLAB)<4)

                       WRITE " "

                   WRITE DGLAB

                   if ($LENGTH(DGLAB)<3)

                       WRITE " "

                   WRITE "|"

 +10      ;100%| 90%| 80%| 70%| 60%| 50%| 40%| 30%| 20%| 10%| 0% | Oth|    | IR | Vet|Pens|caid| 'A'| 'B'| 'C'|"

 +11       SET DGXI=$X

           WRITE $CHAR(13),$EXTRACT(DGL,1,DGXI)

 +12       WRITE !,DGL1

           QUIT

END        SET DGXI=$X

           WRITE $CHAR(13),$EXTRACT(DGL,1,DGXI)

 +1        WRITE !,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."

 +2        WRITE !?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."

 +3        WRITE !?55,"With the exception of Segment 420, BLOCKS 39-40 should always be ZERO.",!

 +4        IF $DATA(DGFL(+DGDV))

               WRITE !!,"***","Not able to generate AMIS - Data segments are out of balance for:",!

 +5        IF $DATA(DGFL(+DGDV))

               FOR X=0:0

                   SET X=$ORDER(DGUB(X))

                   if 'X

                       QUIT

                   WRITE X_$SELECT($ORDER(DGUB(X)):",",1:"")

 +6        WRITE !,DGL1

 +7        SET Y=$PIECE(DGEN,"^",5)

           XECUTE ^DD("DD")

           WRITE !,"Totals last generated on '",Y,"' by '",$SELECT($DATA(^VA(200,+$PIECE(DGEN,"^",4),0)):$PIECE(^(0),"^",1),1:"UNKNOWN USER"),"'.",?(127-$LENGTH(DGWHEN)-1),DGWHEN,!

           QUIT

SET        DO H^DGUTL

           SET Y=DGTIME

           XECUTE ^DD("DD")

           SET DGWHEN="Report Printed: "_Y

           SET (DGL,DGL1,DGEN)=""

 +1        SET DGWIDTH=132

           FOR DGII=401:1:420

               SET X=$PIECE(^DG(391.1,DGII,0),U,3)

               IF (X>0)&(X<DGA)

                   SET DGWIDTH=DGWIDTH-5

 +2        SET $PIECE(DGL,"_",(DGWIDTH-1))=""

           SET $PIECE(DGL1,"=",DGWIDTH)=""

           KILL ^UTILITY($JOB,"DGSEG")

           QUIT

REP       ;Reprint

 +1        DO SET

           SET I1=+DGPR

           SET DGDD(I1)=""

           FOR I=401:1:420

               SET X=$SELECT($DATA(^DG(391.1,I,"D",I1,"MY",DGA,"A1")):^("A1"),1:"")

               SET ^UTILITY($JOB,"DGSEG",I1,I)=X

               IF 'DGEN

                   IF $DATA(^DG(391.1,I,"D",I1,"MY",DGA,0))

                       SET DGEN=^(0)

 +2        GOTO EN1

REP1       GOTO EN

SAV        SET DGFLG=0

           FOR DGI=0:0

               SET DGI=$ORDER(^UTILITY($JOB,"DGSEG",DGI))

               if 'DGI

                   QUIT

               FOR DGI1=0:0

                   SET DGI1=$ORDER(^UTILITY($JOB,"DGSEG",DGI,DGI1))

                   if 'DGI1

                       QUIT

                   SET DGN=^(DGI1)

                   SET DGFLG=0

                   DO ^DGA4007

                   DO SAV1

 +1        IF DGCODFLG=1

               FOR DGDIV=0:0

                   SET DGDIV=$ORDER(DGDIV(DGDIV))

                   if 'DGDIV

                       QUIT

                   IF DGDIV(DGDIV)

                       SET DGSEG=401

                       SET DGMYR=DGA

                       DO QUE^DGGECSA

 +2        KILL DGSEG,DGDIV,DGMYR

 +3        KILL 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($JOB,"DGSEG"),^("DGDIS")

 +4        GOTO EN

SAV1       IF '$DATA(^DG(391.1,DGI,0))

               SET DIC="^DG(391.1,"

               SET (X,DA,DINUM)=DGI

               SET DIC(0)="L"

               KILL DD,DO

               DO FILE^DICN

 +1        if '$DATA(^DG(391.1,DGI,"D",0))

               SET ^(0)="^391.11P^^"

           IF '$DATA(^DG(391.1,DGI,"D",DGI1,0))

               SET DIC="^DG(391.1,"_DGI_",""D"","

               SET DA(1)=DGI

               SET (X,DA,DINUM)=DGI1

               SET DIC(0)="L"

               KILL DD,DO

               DO FILE^DICN

 +2        if '$DATA(^DG(391.1,DGI,"D",DGI1,"MY",0))

               SET ^(0)="^391.12D^^"

           IF '$DATA(^DG(391.1,DGI,"D",DGI1,"MY",DGA,0))

               SET DIC="^DG(391.1,"_DGI_",""D"","_DGI1_",""MY"","

               SET DA(2)=DGI

               SET DA(1)=DGI1

               SET (X,DA,DINUM)=DGA

               SET DIC(0)="L"

               KILL DD,DO

               DO FILE^DICN

 +3        IF $DATA(DGFLG)

               SET $PIECE(^DG(391.1,DGI,"D",DGI1,"MY",DGA,0),"^",6)=$SELECT(DGFLG:1,1:0)

               SET DGDIV(DGI1)=DGFLG

               IF 'DGFLG

                   SET DGFL(DGI1)=""

 +4        DO H^DGUTL

           IF $PIECE(^DG(391.1,DGI,"D",DGI1,"MY",DGA,0),"^",2)=""

               SET $PIECE(^(0),"^",2)=DUZ

               SET $PIECE(^(0),"^",3)=DGTIME

 +5        SET $PIECE(^DG(391.1,DGI,"D",DGI1,"MY",DGA,0),"^",4)=DUZ

           SET $PIECE(^(0),"^",5)=DGTIME

 +6        if IO=DGDEV

               WRITE "."

           SET ^DG(391.1,DGI,"D",DGI1,"MY",DGA,"A1")=DGN

           SET DGN=""

           QUIT

OKDATE(SEGMENT) ;

 +1       ;NEEDS DGA TO BE DEFINED

 +2       ;INACTDT=AMIS SEGMENT INACTIVATION DATE

 +3        NEW INACTDT,DGFL

 +4        SET INACTDT=$SELECT(('$DATA(^DG(391.1,SEGMENT,0))):0,1:$PIECE(^DG(391.1,SEGMENT,0),"^",3))

 +5        SET DGFL=0

           IF (INACTDT']"")!(INACTDT>DGA)

               SET DGFL=1

 +6        QUIT DGFL

DGA4005.m