AGCO.m

AGCO ; IHS/ASDS/EFG - ALPHA LIST OF COMM OFFICERS & DEPENDENTS ;  

 ;;7.1;PATIENT REGISTRATION;**4**;AUG 25,2005

 S AGIO=IO,AG("HAT")=""

DEV S %ZIS="OPQ" D ^%ZIS I POP S IOP=ION D ^%ZIS G K

 G:'$D(IO("Q")) START K IO("Q") I $D(IO("S"))!($E(IOST)'="P") W *7,!,"Please queue to system printers." D ^%ZISC G DEV

 X ^%ZOSF("UCI") S ZTRTN="START^AGCO",ZTUCI=Y,ZTIO="",ZTDESC="LIST OF COMMISSIONED OFFICERS AND DEPENDANTS.",AGQIO=IO S G="AGQIO",ZTSAVE(G)=""

 D ^%ZTLOAD G:'$D(ZTSK) DEV

 K ZTDESC,ZTIO,ZTRTN,ZTSK,ZTUCI

 G K

START ;EP - From TaskMan.

 K ^TMP($J) F AGBEN=3,4,28,29 F DFN=0:0 S DFN=$O(^AUPNPAT("AD",AGBEN,DFN)) Q:'DFN  I $D(^DPT(DFN,0)),$D(^AUPNPAT(DFN,41,DUZ(2),0)),$P(^(0),U,3)="",$P(^AUPNPAT(DFN,11),U,11)=AGBEN S ^TMP($J,AGBEN,$P(^DPT(DFN,0),U),DFN)=""

 S (AGPGPG,N,AGTOT)=0,X=$P(^DIC(4,DUZ(2),0),U) D CTR^AG S AG("LOC")=X,AG("USR")=$P(^VA(200,DUZ,0),U) K ^UTILITY("DIQ1",$J)

 X ^%ZOSF("UCI") S X="UCI: "_$P(Y,",",1) D CTR^AG S AGUCI=X

 D NOW^AG S X="as of "_AGTIME D CTR^AG S AGTIME=X,AGBEN=0

 I $D(AGQIO) F AGZ("I")=1:1 S IOP=AGQIO D ^%ZIS Q:'POP  H 30

 S AGBM=IOSL-10 I $D(AGIO),AGIO'=IO S AGBM=IOSL-4

 U IO D HDR

 F AGBEN=3,4,28,29 S AGNAME="" F AG=0:0 S AGNAME=$O(^TMP($J,AGBEN,AGNAME)) G:AGNAME=""&(AGBEN=29) END Q:AGNAME=""  S DFN=$O(^(AGNAME,0)) D PRINT G:$D(DUOUT)!$D(DFOUT)!$D(DTOUT) K

PRINT W $P(^DPT(DFN,0),U),?45,$J($P(^AUPNPAT(DFN,41,DUZ(2),0),U,2),6)

 ;I $D(^AUPNPAT(DFN,11)) S DIC=2,DR=.09,DA=DFN K ^UTILITY("DIQ1",$J,DR) D EN^DIQ1 W:$D(^(DR)) ?54,^(DR) W ?68,$S(AGBEN=3:"C. O.",AGBEN=4:"DEPENDENT",AGBEN=28:"RET C. O.",AGBEN=29:"RET C. O. DEP",1:"")

 I $D(^AUPNPAT(DFN,11)) S DIC=9000001,DR=1107.3,DA=DFN K ^UTILITY("DIQ1",$J,DR) D EN^DIQ1 W:$D(^(DR)) ?54,^(DR) W ?68,$S(AGBEN=3:"C. O.",AGBEN=4:"DEPENDENT",AGBEN=28:"RET C. O.",AGBEN=29:"RET C. O. DEP",1:"")  ;IHS/SD/TPF AG*7.1*4

 W ! S AGTOT=AGTOT+1 I $Y>AGBM D RTRN^AG Q:$D(DUOUT)!$D(DTOUT)!$D(DFOUT)  D HDR

 Q

END W !!,"Total Listings: ",AGTOT K AG("HAT") D RTRN^AG W $$S^AGVDF("IOF")

K D ^%ZISC K ^UTILITY("DIQ1",$J),^TMP($J),AG,AGBM,AGIO,AGQIO,AGTIME,AGTOT,AGBEN,DA,DFN,DIC,DR,AG("LOC"),AGNAME,AGPGPG,AGUCI,AG("USR"),X,Y D:$D(ZTQUEUED) KILL^%ZTLOAD

 Q

HDR S AGPGPG=AGPGPG+1

 W $$S^AGVDF("IOF"),!!,AG("USR"),?72,"page ",AGPGPG,!,AG("LOC"),!?27,"COMM. OFFICERS & DEPENDENTS",!,AGUCI,!?32,"(""*"" = INACTIVE)",!,AGTIME

 W !!!?18,"Name",?46,"IHS #",?58,"SSN",?69,"CLASS.",!,"----------------------------------------",?45,"------   -----------   ----------",!

 Q

AGCO      ; IHS/ASDS/EFG - ALPHA LIST OF COMM OFFICERS & DEPENDENTS ;  

 +1       ;;7.1;PATIENT REGISTRATION;**4**;AUG 25,2005

 +2        SET AGIO=IO

           SET AG("HAT")=""

DEV        SET %ZIS="OPQ"

           DO ^%ZIS

           IF POP

               SET IOP=ION

               DO ^%ZIS

               GOTO K

 +1        IF '$DATA(IO("Q"))

               GOTO START

           KILL IO("Q")

           IF $DATA(IO("S"))!($EXTRACT(IOST)'="P")

               WRITE *7,!,"Please queue to system printers."

               DO ^%ZISC

               GOTO DEV

 +2        XECUTE ^%ZOSF("UCI")

           SET ZTRTN="START^AGCO"

           SET ZTUCI=Y

           SET ZTIO=""

           SET ZTDESC="LIST OF COMMISSIONED OFFICERS AND DEPENDANTS."

           SET AGQIO=IO

           SET G="AGQIO"

           SET ZTSAVE(G)=""

 +3        DO ^%ZTLOAD

           IF '$DATA(ZTSK)

               GOTO DEV

 +4        KILL ZTDESC,ZTIO,ZTRTN,ZTSK,ZTUCI

 +5        GOTO K

START     ;EP - From TaskMan.

 +1        KILL ^TMP($JOB)

           FOR AGBEN=3,4,28,29

               FOR DFN=0:0

                   SET DFN=$ORDER(^AUPNPAT("AD",AGBEN,DFN))

                   IF 'DFN

                       QUIT 

                   IF $DATA(^DPT(DFN,0))

                       IF $DATA(^AUPNPAT(DFN,41,DUZ(2),0))

                           IF $PIECE(^(0),U,3)=""

                               IF $PIECE(^AUPNPAT(DFN,11),U,11)=AGBEN

                                   SET ^TMP($JOB,AGBEN,$PIECE(^DPT(DFN,0),U),DFN)=""

 +2        SET (AGPGPG,N,AGTOT)=0

           SET X=$PIECE(^DIC(4,DUZ(2),0),U)

           DO CTR^AG

           SET AG("LOC")=X

           SET AG("USR")=$PIECE(^VA(200,DUZ,0),U)

           KILL ^UTILITY("DIQ1",$JOB)

 +3        XECUTE ^%ZOSF("UCI")

           SET X="UCI: "_$PIECE(Y,",",1)

           DO CTR^AG

           SET AGUCI=X

 +4        DO NOW^AG

           SET X="as of "_AGTIME

           DO CTR^AG

           SET AGTIME=X

           SET AGBEN=0

 +5        IF $DATA(AGQIO)

               FOR AGZ("I")=1:1

                   SET IOP=AGQIO

                   DO ^%ZIS

                   IF 'POP

                       QUIT 

                   HANG 30

 +6        SET AGBM=IOSL-10

           IF $DATA(AGIO)

               IF AGIO'=IO

                   SET AGBM=IOSL-4

 +7        USE IO

           DO HDR

 +8        FOR AGBEN=3,4,28,29

               SET AGNAME=""

               FOR AG=0:0

                   SET AGNAME=$ORDER(^TMP($JOB,AGBEN,AGNAME))

                   IF AGNAME=""&(AGBEN=29)

                       GOTO END

                   IF AGNAME=""

                       QUIT 

                   SET DFN=$ORDER(^(AGNAME,0))

                   DO PRINT

                   IF $DATA(DUOUT)!$DATA(DFOUT)!$DATA(DTOUT)

                       GOTO K

PRINT      WRITE $PIECE(^DPT(DFN,0),U),?45,$JUSTIFY($PIECE(^AUPNPAT(DFN,41,DUZ(2),0),U,2),6)

 +1       ;I $D(^AUPNPAT(DFN,11)) S DIC=2,DR=.09,DA=DFN K ^UTILITY("DIQ1",$J,DR) D EN^DIQ1 W:$D(^(DR)) ?54,^(DR) W ?68,$S(AGBEN=3:"C. O.",AGBEN=4:"DEPENDENT",AGBEN=28:"RET C. O.",AGBEN=29:"RET C. O. DEP",1:"")

 +2       ;IHS/SD/TPF AG*7.1*4

           IF $DATA(^AUPNPAT(DFN,11))

               SET DIC=9000001

               SET DR=1107.3

               SET DA=DFN

               KILL ^UTILITY("DIQ1",$JOB,DR)

               DO EN^DIQ1

               IF $DATA(^(DR))

                   WRITE ?54,^(DR)

               WRITE ?68,$SELECT(AGBEN=3:"C. O.",AGBEN=4:"DEPENDENT",AGBEN=28:"RET C. O.",AGBEN=29:"RET C. O. DEP",1:"")

 +3        WRITE !

           SET AGTOT=AGTOT+1

           IF $Y>AGBM

               DO RTRN^AG

               IF $DATA(DUOUT)!$DATA(DTOUT)!$DATA(DFOUT)

                   QUIT 

               DO HDR

 +4        QUIT 

END        WRITE !!,"Total Listings: ",AGTOT

           KILL AG("HAT")

           DO RTRN^AG

           WRITE $$S^AGVDF("IOF")

K          DO ^%ZISC

           KILL ^UTILITY("DIQ1",$JOB),^TMP($JOB),AG,AGBM,AGIO,AGQIO,AGTIME,AGTOT,AGBEN,DA,DFN,DIC,DR,AG("LOC"),AGNAME,AGPGPG,AGUCI,AG("USR"),X,Y

           IF $DATA(ZTQUEUED)

               DO KILL^%ZTLOAD

 +1        QUIT 

HDR        SET AGPGPG=AGPGPG+1

 +1        WRITE $$S^AGVDF("IOF"),!!,AG("USR"),?72,"page ",AGPGPG,!,AG("LOC"),!?27,"COMM. OFFICERS & DEPENDENTS",!,AGUCI,!?32,"(""*"" = INACTIVE)",!,AGTIME

 +2        WRITE !!!?18,"Name",?46,"IHS #",?58,"SSN",?69,"CLASS.",!,"----------------------------------------",?45,"------   -----------   ----------",!

 +3        QUIT