DGA4006.m

DGA4006 ;ALB/MRL - LIST OF PATIENTS ON AMIS 401-420 SEGMENT ;01 JAN 1988@2300

 ;;5.3;Registration;;Aug 13, 1993

 S DGC=0 F I=0:0 S I=$O(^UTILITY($J,"DGSEGP",I)) Q:'I  D DV^DGA4001,H F I1=0:0 S I1=$O(^UTILITY($J,"DGSEGP",I,I1)),I2="" D:I1'>0&(DGC) END Q:I1'>0  F I4=0:0 S I2=$O(^UTILITY($J,"DGSEGP",I,I1,I2)) Q:I2=""  D 1

 D END:DGC G QUIT^DGA4002

1 F I3=0:0 S I3=$O(^UTILITY($J,"DGSEGP",I,I1,I2,I3)) Q:'I3  S X=^(I3),X2=$P(I3,".",2),X1=$E(I3,4,5)_"/"_$E(I3,6,7)_"/"_$E(I3,2,3)_"@"_$E($E(X2,1,2)_"00",1,2)_":"_$E($E(X2,3,4)_"00",1,2) D W

 Q

W I $Y>$S($D(IOSL):(IOSL-6),1:58) D:DGC END D H

 S DGC=1 W !,I1,?5,I2,?22,$S($P(X,"^",2)]"":$P(X,"^",2),1:"----"),?28,X1,?46,$P(X,"^",4),?60,$P(X,"^",3) S X3=$P(X,"^",1) W ?90,$E(X3,1,$L(X3)-1),?100,$P(X,"^",5) Q

H W @IOF,!,"PATIENTS INCLUDED ON '",$P(DGDV,"^",2),"' DIVISION, AMIS 401-420 SEGMENTS, " S Y=DGA X ^DD("DD") W Y,!,DGL1

 W !,"SEG",?5,"Patient Name",?22,"SSN4",?28,"Reg Date/Time",?46,"Benefit",?60,"Reg Elig Code",?90,"*Blocks",?100,"Disposition Type",!,DGL1 Q

END S DGC=0 W !!,DGL1,!,"* - Block 01 (applications received) is presumed for all patients!",!!,"**Dispositions with an UNSCHEDULED status will no longer be counted on this AMIS as of Oct 1, 1989**",! Q

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---DGA4006   1228     printed  Apr 09, 2024@21:38:28                                                                                                                                                                                                     Page 2

DGA4006   ;ALB/MRL - LIST OF PATIENTS ON AMIS 401-420 SEGMENT ;01 JAN 1988@2300

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

 +2        SET DGC=0

           FOR I=0:0

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

               if 'I

                   QUIT 

               DO DV^DGA4001

               DO H

               FOR I1=0:0

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

                   SET I2=""

                   if I1'>0&(DGC)

                       DO END

                   if I1'>0

                       QUIT 

                   FOR I4=0:0

                       SET I2=$ORDER(^UTILITY($JOB,"DGSEGP",I,I1,I2))

                       if I2=""

                           QUIT 

                       DO 1

 +3        if DGC

               DO END

           GOTO QUIT^DGA4002

1          FOR I3=0:0

               SET I3=$ORDER(^UTILITY($JOB,"DGSEGP",I,I1,I2,I3))

               if 'I3

                   QUIT 

               SET X=^(I3)

               SET X2=$PIECE(I3,".",2)

               SET X1=$EXTRACT(I3,4,5)_"/"_$EXTRACT(I3,6,7)_"/"_$EXTRACT(I3,2,3)_"@"_$EXTRACT($EXTRACT(X2,1,2)_"00",1,2)_":"_$EXTRACT($EXTRACT(X2,3,4)_"00",1,2)

               DO W

 +1        QUIT 

W          IF $Y>$SELECT($DATA(IOSL):(IOSL-6),1:58)

               if DGC

                   DO END

               DO H

 +1        SET DGC=1

           WRITE !,I1,?5,I2,?22,$SELECT($PIECE(X,"^",2)]"":$PIECE(X,"^",2),1:"----"),?28,X1,?46,$PIECE(X,"^",4),?60,$PIECE(X,"^",3)

           SET X3=$PIECE(X,"^",1)

           WRITE ?90,$EXTRACT(X3,1,$LENGTH(X3)-1),?100,$PIECE(X,"^",5)

           QUIT 

H          WRITE @IOF,!,"PATIENTS INCLUDED ON '",$PIECE(DGDV,"^",2),"' DIVISION, AMIS 401-420 SEGMENTS, "

           SET Y=DGA

           XECUTE ^DD("DD")

           WRITE Y,!,DGL1

 +1        WRITE !,"SEG",?5,"Patient Name",?22,"SSN4",?28,"Reg Date/Time",?46,"Benefit",?60,"Reg Elig Code",?90,"*Blocks",?100,"Disposition Type",!,DGL1

           QUIT 

END        SET DGC=0

           WRITE !!,DGL1,!,"* - Block 01 (applications received) is presumed for all patients!",!!,"**Dispositions with an UNSCHEDULED status will no longer be counted on this AMIS as of Oct 1, 1989**",!

           QUIT