Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: AGUND18

AGUND18.m

Go to the documentation of this file. 
  1. AGUND18 ; IHS/ASDS/TPF - PRINT ALL PATS UNDER 18 WITH MEDICAID/PRIVATE/SOC SEC NUMBERS ;  
  1.  ;;7.1;PATIENT REGISTRATION;**2,4**;JAN 31, 2007
  1.  ;TASK REQUESTS REPORT BE SIMILAR TO OVER 65 REPORT - TEMPPLATE USED FROM AGOV64
  1.  S AGIO=IO,AG("HAT")=""
  1.  W !!
  1.  K DIR
  1.  S DIR(0)="Y"
  1.  S DIR("A")="Include inactive patients?"
  1.  S DIR("B")="N"
  1.  D ^DIR
  1.  Q:$D(DUOUT)!$D(DTOUT)
  1.  S AGINACT=+Y
  1.  K DTOUT,DUOUT,DIR
  1.  W !!
  1. DEV S %ZIS="OPQ" D ^%ZIS I POP S IOP=ION D ^%ZIS Q
  1.  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
  1.  ;X ^%ZOSF("UCI") S ZTRTN="START^AGUND18",ZTUCI=Y,ZTIO="",ZTDESC="PATIENTS UNDER 18 for "_$P(^AUTTLOC(DUZ(2),0),U,2)_".",AGQIO=IO F G="AGQIO","DUZ" S ZTSAVE(G)=""
  1.  X ^%ZOSF("UCI") S ZTRTN="START^AGUND18",ZTUCI=Y,ZTIO="",ZTDESC="PATIENTS UNDER 18 for "_$P(^AUTTLOC(DUZ(2),0),U,2)_".",AGQIO=IO F G="AGINACT","AGQIO","DUZ" S ZTSAVE(G)=""  ;AG*7.1*4 HEAT1653
  1.  D ^%ZTLOAD G:'$D(ZTSK) DEV K AG,AGIO,ZTDESC,ZTIO,ZTRTN,ZTSK,ZTUCI D ^%ZISC
  1.  Q
  1. START ;EP - From TaskMan.
  1.  S AG("18")=DT-180000,(AGTOT,AGTOTMCD,AGTOTPRV,AGPGPG)=0
  1.  K ^TMP($J),AG("LOC"),AG("USR")
  1.  S I=AG("18")
  1.  F  S I=$O(^DPT("ADOB",I)) Q:I=""  D
  1.  .;S J=$O(^(I,""))
  1.  .S J=$O(^DPT("ADOB",I,""))  ;AG*1.8*4 SAC:TOOK OUT NAKED REFERENCE
  1.  .Q:($P($G(^AUPNPAT(J,41,DUZ(2),0)),U,3)'="")&('AGINACT)
  1.  .I $D(^AUPNPAT(J,41,DUZ(2))),$D(^DPT(J,0)),'$P($G(^DPT(J,.35)),U) S NAME=$P($G(^DPT(J,0)),U) S ^TMP($J,NAME)=J
  1.  I $D(AGQIO) F AGZ("I")=1:1 S IOP=AGQIO D ^%ZIS Q:'POP
  1.  S AG("LOC")=$P(^DIC(4,DUZ(2),0),U),AG("USR")=$P(^VA(200,DUZ,0),U)
  1.  S AG("USRLOC")=AG("USR")_$J("",40-($L(AG("LOC"))\2)-$L(AG("USR")))_AG("LOC"),AGBM=IOSL-10
  1.  I $D(AGIO),AGIO=IO S AGBM=IOSL-4
  1.  K AG("LOC"),AG("USR")
  1.  U IO
  1.  D LINES^AG,NOW^AG
  1.  S X="Report date: "_AGTIME D CTR^AG S AGTIME=X D HDR
  1.  ;MAIN LOOP
  1.  K DUOUT,DFOUT,DTOUT
  1.  S NAME=""
  1.  F  S NAME=$O(^TMP($J,NAME)) Q:NAME=""  D  Q:$D(DUOUT)!$D(DFOUT)!$D(DTOUT)
  1.  .S DFN=$G(^TMP($J,NAME))
  1.  .S AGRRESW="N"
  1.  .S MCDREC=""
  1.  .S PRVTREC=0
  1.  .D PRINT
  1.  .I $Y>AGBM D RTRN^AG Q:$D(DUOUT)!$D(DFOUT)!$D(DTOUT)  D HDR
  1.  K AG("HAT")
  1.  Q:$D(DUOUT)!$D(DFOUT)!$D(DTOUT)
  1.  D RTRN^AG W !!,"Total patients 18 yrs or younger: ",AGTOT,!!,"Total patients 18 or younger with Medicaid: ",AGTOTMCD,!! D RTRN^AG W $$S^AGVDF("IOF")
  1. END D ^%ZISC K ^TMP($J),A,AG,AGIO,AGTIME,AGBM,DA,DIC,DLOUT,DR,G,AGL,I,J,AG("LKDATA"),AG("LKPRINT"),AGPCC,AGPGPG,AGRRESW,AGTOT,AGTOTM,AGTOTR,AG("USRLOC"),X,Y D:$D(ZTQUEUED) KILL^%ZTLOAD
  1.  Q
  1. PRINT ;
  1.  S AGTOT=AGTOT+1
  1.  W $P($G(^DPT(DFN,0)),U)," (",$P(^AUPNPAT(DFN,41,DUZ(2),0),U,2),")"
  1.  ;AG*7.1*2 REQUESTED DURIGN TESTING
  1.  S Y=$P($G(^DPT(DFN,0)),U,3)
  1.  I Y'="" X ^DD("DD") S AGDOB=Y
  1.  E  S AGDOB=""
  1.  I $D(^DPT(DFN,.13)) D
  1.  .S AGPHONE=$P($G(^DPT(DFN,.13)),U)
  1.  .S AGPHONE=$S($L(AGPHONE)=10:$E(AGPHONE,1,3)_"-"_$E(AGPHONE,4,6)_"-"_$E(AGPHONE,7,10),$L(AGPHONE)=7:$E(AGPHONE,1,3)_"-"_$E(AGPHONE,4,7),1:AGPHONE)
  1.  .W ?35,AGPHONE K AGPHONE
  1.  D MCD I MCDREC="" D PRVT
  1.  ;W ?69,$P(^DPT(DFN,0),U,9)  ;SSN
  1.  W ?69,$$GET1^DIQ(9000001,DFN_",",1107.3)  ;IHS/SD/TPF AG*7.1*4
  1.  S AGADDR=$G(^DPT(DFN,.11))
  1.  W:$P(AGADDR,U)]"" !?10,$P(AGADDR,U)
  1.  W ?35,AGDOB   ;AG*7.1*2 REQUEST DURING TESTING
  1.  I MCDREC'="" D MCD G NEXT1
  1.  D:PRVTREC&(MCDREC'="") PRVT
  1. NEXT1 S AG("ADDR")=$P(AGADDR,U,4)_" "
  1.  I $P(AGADDR,U,5)]"",$D(^DIC(5,$P(AGADDR,U,5),0)) D
  1.  .;S AG("ADDR")=AG("ADDR")_$P(^(0),U,2)_" "
  1.  .S AG("ADDR")=AG("ADDR")_$P($G(^DIC(5,$P(AGADDR,U,5),0)),U,2)_" " ;AG*1.8*4 SAC:TOOK OUT NAKED REFERENCE
  1.  W !?10,AG("ADDR")
  1.  I MCDREC'="" D MCD G NEXT2
  1.  D:PRVTREC&(MCDREC="") PRVT
  1. NEXT2 D MCDNM
  1.  F  D:$G(MCDREC)'="" MCD D:$G(MCDREC)=""&($G(PRVTREC)) PRVT Q:$G(MCDREC)=""&('$G(PRVTREC))
  1.  W !,AG("-"),!
  1.  Q
  1. HDR S AGPGPG=AGPGPG+1
  1.  W $$S^AGVDF("IOF")
  1.  W !,AG("USRLOC"),?70,"page ",AGPGPG
  1.  W !?26,"PATIENTS <18 YRS OLD"
  1.  W !,AGTIME
  1.  W !!?35,"HOME PHONE",?51,"MEDICAID(M)",?69,"SOCIAL"
  1.  W !,"NAME (CHART #)",?35,"DATE OF BIRTH",?51,"PRIVATE(P)",?66,"SECURITY NO."
  1.  W !,AG("="),!
  1.  Q
  1. PRVT ;
  1.  S PRVTREC=$O(^AUPNPRVT(DFN,11,PRVTREC)) Q:'PRVTREC
  1.  S AGPRVTNM=$P($G(^AUPNPRVT(DFN,11,PRVTREC,2)),U)
  1.  W:AGPRVTNM]"" ?49,"P=",AGPRVTNM K AGPRVTNM
  1.  S AGTOTPRV=AGTOTPRV+1
  1.  Q
  1. MCD ;
  1.  S MCDREC=$O(^AUPNMCD("B",DFN,MCDREC)) Q:MCDREC=""
  1.  S AGMCDNO=$P($G(^AUPNMCD(MCDREC,0)),U,3)
  1.  S:$L(AGMCDNO)=9 AGMCDNO=$E(AGMCDNO,1,3)_"-"_$E(AGMCDNO,4,5)_"-"_$E(AGMCDNO,6,9)
  1.  W:AGMCDNO]"" ?49,"M=",AGMCDNO
  1.  W:AGMCDNO="" ?49,"NO NUMBER "
  1.  S AGTOTMCD=AGTOTMCD+1
  1.  Q
  1. MCDNM ;
  1.  K AGMCRNM
  1.  S MCDRECNO=""
  1.  F  S MCDRECNO=$O(^AUPNMCD("B",DFN,MCDRECNO)) Q:MCDRECNO=""  D
  1.  .S AGMCDNM=$P($G(^AUPNMCD(MCDRECNO,21)),U)
  1.  .W:AGMCDNM]"" !,"(MCD) ",AGMCDNM K AGMDRNM
  1.  .I MCDREC'="" D MCD Q
  1.  .D:PRVTREC'="" PRVT
  1.  S PRVTREC=0
  1.  F  S PRVTREC=$O(^AUPNPRVT(DFN,11,PRVTREC)) Q:'PRVTREC  D
  1.  .S AGPOLNM=$$GET1^DIQ(9000006.11,PRVTREC_","_DFN_",",.08,"E")
  1.  .W:AGPOLNM'="" !,"(PRVT) ",AGPOLNM K AGPOLNM
  1.  Q