Routine: DGGECS

DGGECS ;ALB/RMO/REW - MAS Generic Code Sheet Interface for AMIS ; 13 JUN 89 9:45 am

 ;;5.3;Registration;**50,70,151**;Aug 13, 1993

 ;Interface includes AMIS Segments 334-341, 345-346 and 401-420

AMS S DGRD("A")="Select AMIS SEGMENTS: ",DGRD(0)="S",DGRD(1)="334-341^generate code sheets for AMIS 334-341's."

 S DGRD(2)="345-346^generate code sheets for AMIS 345-346's.",DGRD(3)="401-420^generate code sheets for AMIS 401-420's."

 D SET^DGGECSR N ENT K DGRD G Q:X["^"!(X="") S DGARNG=X

 F I=+DGARNG:1 D  Q:I+1>$P(DGARNG,"-",2)

 .S ENT=$O(^GECS(2101.2,"B",I,""))

 .I $P(^GECS(2101.2,ENT,0),"^",5)="Y" S DGAMS(I)=""

DIV K DGDIV I $D(^DG(43,1,"GL")),$P(^("GL"),"^",2),DGARNG'="334-341",DGARNG'="345-346" S DIC("A")="Select DIVISION: ",DIC="^DG(40.8,",DIC(0)="AEMQ" D ^DIC K DIC G Q:Y<0 S DGDIV=+Y

 S DGDIV=$S($D(DGDIV):DGDIV,1:+$O(^DG(40.8,0)))

 ;MOVED DGSTA DEF TO AFTER MYR TO BE DATE DEPENDENT

MYR W !,"Select MONTH/YEAR: " R X:DTIME G Q:'$T!(X="")!(X["^")

 S %DT="EP",%DT(0)="-NOW" D ^%DT K %DT S DGERR=$S($E(Y,6,7)'="00":1,1:0) W:DGERR !!?2,"Do not specify day of month or a month/year in the future.",! G MYR:Y<0!(DGERR) S DGMYR=Y

 S DGSTA=$P($$SITE^VASITE(DGMYR+1,DGDIV),U,3) ; use +1 to get first day of month for proper site #

 I $G(DGSTA)'>0 S DGSTA=$S('$D(^DG(40.8,+DGDIV,0)):0,$P(^(0),"^",2)'="":$P(^(0),"^",2),$D(^DIC(4,+$P(^(0),"^",7),99)):$P(^(99),"^",1),1:0)

 I DGARNG="334-341"!(DGARNG="345-346") F I=+DGARNG:1:$P(DGARNG,"-",2) S DGERR=$S($D(^DGAM(+DGARNG,DGMYR,"SE",I,"D",DGDIV,0)):0,1:1) Q:'DGERR!(I+1>$P(DGARNG,"-",2))

 I DGARNG="401-420" S DGERR=1 F I=+DGARNG:1:$P(DGARNG,"-",2) D  Q:'DGERR!(I+1>$P(DGARNG,"-",2))

 . F J=0:0 S J=$O(^DG(391.1,I,"D",J)) Q:'J  I $D(^(J,"MY",DGMYR,"A1")) S DGERR=0 Q

 I DGERR W !!?2,*7,"AMIS ",DGARNG," data has not been generated for this month/year.",! G MYR

BAL K DGNOB I DGARNG="334-341"!(DGARNG="345-346") F I=+DGARNG:1:$P(DGARNG,"-",2) I $D(^DGAM(+DGARNG,DGMYR,"SE",I,0)),'$P(^(0),"^",2) S DGNOB(I)=""

 I DGARNG="401-420" F I=+DGARNG:1:$P(DGARNG,"-",2) I $D(^DG(391.1,I,"D",DGDIV,"MY",DGMYR,0)),'$P(^(0),"^",6) S DGNOB(I)=""

 I $D(DGNOB) D MSG G AMS

 S DGPGM="START^DGGECS",DGVAR="DGAMS#^DGDIV^DGSTA^DGMYR" W ! D ZIS^DGUTQ G Q:POP

START U IO S SDABORT=0

 F DGTTF=0:0 S DGTTF=$O(DGAMS(DGTTF)) Q:'DGTTF!SDABORT  D

 .S DGX=$P($G(^DG(391.1,DGTTF,0)),U,3)

 .I (DGX>0)&((DGX-100)<DGMYR) K DGAMS(DGTTF) Q  ;OK IF INACTIVE MONTH

 .S DGSTR="" D BLD,GEN:'SDABORT

Q K DGX,DGAMS,DGARNG,DGDIV,DGEND,DGERR,DGFLG,DGHDR,DGMYR,DGNOB,DGPGM,DGRD,DGSFX,DGSTA,DGSTR,DGTTF,DGVAR,I,J,POP,SDABORT,X,Y D CLOSE^DGUTQ

MSG W !!?2,*7,"AMIS ",DGARNG," code sheets can not be generated for this month/year",!?2,"until the following segments are balanced:" W !!?2 F I=0:0 S I=$O(DGNOB(I)) Q:'I  W "  ",I

BLD S DGEND=$S(DGTTF=334!(DGTTF=336):15,DGTTF>333&(DGTTF<342):14,DGTTF>344&(DGTTF<347):17,DGTTF=420:40,DGTTF>400&(DGTTF<421):38,1:0) F I=1:1:DGEND S $P(DGSTR,"^",I)=0

 I DGTTF=334 F J=0:0 S J=$O(^DGAM(334,DGMYR,"SE",DGTTF,"D",J)) Q:'J  I $D(^(J,0)) S X=^(0) F I=1:1:DGEND S $P(DGSTR,"^",I)=$P(DGSTR,"^",I)+$S(I=12:+$P(X,"^",24),I=13:+$P(X,"^",I),I>13:+$P(X,"^",I+4),1:+$P(X,"^",I+1))

 I DGTTF>334,DGTTF<342 F J=0:0 S J=$O(^DGAM(334,DGMYR,"SE",DGTTF,"D",J)) Q:'J  I $D(^(J,0)) S X=^(0) F I=1:1:DGEND S $P(DGSTR,"^",I)=$P(DGSTR,"^",I)+$S(I<13:+$P(X,"^",I+1),I=15:0,1:+$P(X,"^",I+5))

 I DGTTF>344,DGTTF<347 F J=0:0 S J=$O(^DGAM(345,DGMYR,"SE",DGTTF,"D",J)) Q:'J  I $D(^(J,0)) S X=^(0) F I=1:1:DGEND S $P(DGSTR,"^",I)=$P(DGSTR,"^",I)+$P(X,"^",I+1)

 I DGTTF>400,DGTTF<421 S X=$G(^DG(391.1,DGTTF,"D",DGDIV,"MY",DGMYR,"A1")) F I=1:1:DGEND S $P(DGSTR,"^",I)=+$P(X,"^",I)

GEN S DGHDR=$S(DGTTF=334:"2^8",DGTTF>334&(DGTTF<342):"M^8",DGTTF>344&(DGTTF<347):"6^8",DGTTF>400&(DGTTF<421):"M^8",1:""),DGSFX=$S(DGTTF>333&(DGTTF<347):"",1:$E(DGSTA,4,5))

 S GECSSYS="MAS",GECS("AMIS")=DGMYR,GECS("SITENOASK")=DGSTA,GECS("TTF")=DGTTF,GECSAUTO="BATCH",GECS("STRING",0)="AMS^((^"_DGHDR_"^"_$E(DGSTA,1,3)_"^"_DGSFX_"^"_DGTTF_"^^"_DGSTR_"^$" W @IOF D ^GECSENTR

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGGECS   4055     printed  Mar 13, 2025@21:48:11                                                                                                                                                                                                      Page 2

DGGECS    ;ALB/RMO/REW - MAS Generic Code Sheet Interface for AMIS ; 13 JUN 89 9:45 am

 +1       ;;5.3;Registration;**50,70,151**;Aug 13, 1993

 +2       ;

 +3       ;Interface includes AMIS Segments 334-341, 345-346 and 401-420

AMS        SET DGRD("A")="Select AMIS SEGMENTS: "

           SET DGRD(0)="S"

           SET DGRD(1)="334-341^generate code sheets for AMIS 334-341's."

 +1        SET DGRD(2)="345-346^generate code sheets for AMIS 345-346's."

           SET DGRD(3)="401-420^generate code sheets for AMIS 401-420's."

 +2        DO SET^DGGECSR

           NEW ENT

           KILL DGRD

           if X["^"!(X="")

               GOTO Q

           SET DGARNG=X

 +3        FOR I=+DGARNG:1

               Begin DoDot:1

 +4                SET ENT=$ORDER(^GECS(2101.2,"B",I,""))

 +5                IF $PIECE(^GECS(2101.2,ENT,0),"^",5)="Y"

                       SET DGAMS(I)=""

               End DoDot:1

               if I+1>$PIECE(DGARNG,"-",2)

                   QUIT

 +6       ;

DIV        KILL DGDIV

           IF $DATA(^DG(43,1,"GL"))

               IF $PIECE(^("GL"),"^",2)

                   IF DGARNG'="334-341"

                       IF DGARNG'="345-346"

                           SET DIC("A")="Select DIVISION: "

                           SET DIC="^DG(40.8,"

                           SET DIC(0)="AEMQ"

                           DO ^DIC

                           KILL DIC

                           if Y<0

                               GOTO Q

                           SET DGDIV=+Y

 +1        SET DGDIV=$SELECT($DATA(DGDIV):DGDIV,1:+$ORDER(^DG(40.8,0)))

 +2       ;MOVED DGSTA DEF TO AFTER MYR TO BE DATE DEPENDENT

 +3       ;

MYR        WRITE !,"Select MONTH/YEAR: "

           READ X:DTIME

           if '$TEST!(X="")!(X["^")

               GOTO Q

 +1        SET %DT="EP"

           SET %DT(0)="-NOW"

           DO ^%DT

           KILL %DT

           SET DGERR=$SELECT($EXTRACT(Y,6,7)'="00":1,1:0)

           if DGERR

               WRITE !!?2,"Do not specify day of month or a month/year in the future.",!

           if Y<0!(DGERR)

               GOTO MYR

           SET DGMYR=Y

 +2       ; use +1 to get first day of month for proper site #

           SET DGSTA=$PIECE($$SITE^VASITE(DGMYR+1,DGDIV),U,3)

 +3        IF $GET(DGSTA)'>0

               SET DGSTA=$SELECT('$DATA(^DG(40.8,+DGDIV,0)):0,$PIECE(^(0),"^",2)'="":$PIECE(^(0),"^",2),$DATA(^DIC(4,+$PIECE(^(0),"^",7),99)):$PIECE(^(99),"^",1),1:0)

 +4        IF DGARNG="334-341"!(DGARNG="345-346")

               FOR I=+DGARNG:1:$PIECE(DGARNG,"-",2)

                   SET DGERR=$SELECT($DATA(^DGAM(+DGARNG,DGMYR,"SE",I,"D",DGDIV,0)):0,1:1)

                   if 'DGERR!(I+1>$PIECE(DGARNG,"-",2))

                       QUIT

 +5        IF DGARNG="401-420"

               SET DGERR=1

               FOR I=+DGARNG:1:$PIECE(DGARNG,"-",2)

                   Begin DoDot:1

 +6                    FOR J=0:0

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

                           if 'J

                               QUIT

                           IF $DATA(^(J,"MY",DGMYR,"A1"))

                               SET DGERR=0

                               QUIT

                   End DoDot:1

                   if 'DGERR!(I+1>$PIECE(DGARNG,"-",2))

                       QUIT

 +7        IF DGERR

               WRITE !!?2,*7,"AMIS ",DGARNG," data has not been generated for this month/year.",!

               GOTO MYR

 +8       ;

BAL        KILL DGNOB

           IF DGARNG="334-341"!(DGARNG="345-346")

               FOR I=+DGARNG:1:$PIECE(DGARNG,"-",2)

                   IF $DATA(^DGAM(+DGARNG,DGMYR,"SE",I,0))

                       IF '$PIECE(^(0),"^",2)

                           SET DGNOB(I)=""

 +1        IF DGARNG="401-420"

               FOR I=+DGARNG:1:$PIECE(DGARNG,"-",2)

                   IF $DATA(^DG(391.1,I,"D",DGDIV,"MY",DGMYR,0))

                       IF '$PIECE(^(0),"^",6)

                           SET DGNOB(I)=""

 +2        IF $DATA(DGNOB)

               DO MSG

               GOTO AMS

 +3       ;

 +4        SET DGPGM="START^DGGECS"

           SET DGVAR="DGAMS#^DGDIV^DGSTA^DGMYR"

           WRITE !

           DO ZIS^DGUTQ

           if POP

               GOTO Q

 +5       ;

START      USE IO

           SET SDABORT=0

 +1        FOR DGTTF=0:0

               SET DGTTF=$ORDER(DGAMS(DGTTF))

               if 'DGTTF!SDABORT

                   QUIT

               Begin DoDot:1

 +2                SET DGX=$PIECE($GET(^DG(391.1,DGTTF,0)),U,3)

 +3       ;OK IF INACTIVE MONTH

                   IF (DGX>0)&((DGX-100)<DGMYR)

                       KILL DGAMS(DGTTF)

                       QUIT

 +4                SET DGSTR=""

                   DO BLD

                   if 'SDABORT

                       DO GEN

               End DoDot:1

 +5       ;

Q          KILL DGX,DGAMS,DGARNG,DGDIV,DGEND,DGERR,DGFLG,DGHDR,DGMYR,DGNOB,DGPGM,DGRD,DGSFX,DGSTA,DGSTR,DGTTF,DGVAR,I,J,POP,SDABORT,X,Y

           DO CLOSE^DGUTQ

 +1        QUIT

 +2       ;

MSG        WRITE !!?2,*7,"AMIS ",DGARNG," code sheets can not be generated for this month/year",!?2,"until the following segments are balanced:"

           WRITE !!?2

           FOR I=0:0

               SET I=$ORDER(DGNOB(I))

               if 'I

                   QUIT

               WRITE "  ",I

 +1        QUIT

 +2       ;

BLD        SET DGEND=$SELECT(DGTTF=334!(DGTTF=336):15,DGTTF>333&(DGTTF<342):14,DGTTF>344&(DGTTF<347):17,DGTTF=420:40,DGTTF>400&(DGTTF<421):38,1:0)

           FOR I=1:1:DGEND

               SET $PIECE(DGSTR,"^",I)=0

 +1        IF DGTTF=334

               FOR J=0:0

                   SET J=$ORDER(^DGAM(334,DGMYR,"SE",DGTTF,"D",J))

                   if 'J

                       QUIT

                   IF $DATA(^(J,0))

                       SET X=^(0)

                       FOR I=1:1:DGEND

                           SET $PIECE(DGSTR,"^",I)=$PIECE(DGSTR,"^",I)+$SELECT(I=12:+$PIECE(X,"^",24),I=13:+$PIECE(X,"^",I),I>13:+$PIECE(X,"^",I+4),1:+$PIECE(X,"^",I+1))

 +2        IF DGTTF>334

               IF DGTTF<342

                   FOR J=0:0

                       SET J=$ORDER(^DGAM(334,DGMYR,"SE",DGTTF,"D",J))

                       if 'J

                           QUIT

                       IF $DATA(^(J,0))

                           SET X=^(0)

                           FOR I=1:1:DGEND

                               SET $PIECE(DGSTR,"^",I)=$PIECE(DGSTR,"^",I)+$SELECT(I<13:+$PIECE(X,"^",I+1),I=15:0,1:+$PIECE(X,"^",I+5))

 +3        IF DGTTF>344

               IF DGTTF<347

                   FOR J=0:0

                       SET J=$ORDER(^DGAM(345,DGMYR,"SE",DGTTF,"D",J))

                       if 'J

                           QUIT

                       IF $DATA(^(J,0))

                           SET X=^(0)

                           FOR I=1:1:DGEND

                               SET $PIECE(DGSTR,"^",I)=$PIECE(DGSTR,"^",I)+$PIECE(X,"^",I+1)

 +4        IF DGTTF>400

               IF DGTTF<421

                   SET X=$GET(^DG(391.1,DGTTF,"D",DGDIV,"MY",DGMYR,"A1"))

                   FOR I=1:1:DGEND

                       SET $PIECE(DGSTR,"^",I)=+$PIECE(X,"^",I)

 +5        QUIT

 +6       ;

GEN        SET DGHDR=$SELECT(DGTTF=334:"2^8",DGTTF>334&(DGTTF<342):"M^8",DGTTF>344&(DGTTF<347):"6^8",DGTTF>400&(DGTTF<421):"M^8",1:"")

           SET DGSFX=$SELECT(DGTTF>333&(DGTTF<347):"",1:$EXTRACT(DGSTA,4,5))

 +1        SET GECSSYS="MAS"

           SET GECS("AMIS")=DGMYR

           SET GECS("SITENOASK")=DGSTA

           SET GECS("TTF")=DGTTF

           SET GECSAUTO="BATCH"

           SET GECS("STRING",0)="AMS^((^"_DGHDR_"^"_$EXTRACT(DGSTA,1,3)_"^"_DGSFX_"^"_DGTTF_"^^"_DGSTR_"^$"

           WRITE @IOF

           DO ^GECSENTR

 +2        QUIT

DGGECS.m