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 09, 2024@21:39:21 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
