- 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
