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
Q
;
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
Q
;
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)
Q
;
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
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGGECS 4055 printed Dec 13, 2024@02:43:37 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
