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