AGBIC1B ; IHS/ASDS/EFG - WRITE BENEFICIARY ID CARD (BIC) ;
;;7.1;PATIENT REGISTRATION;**11**;AUG 25,2005;Build 1
;IHS/OIT/NKD AG*7.1*11 MU2 UNKNOWN SEX
;
START ;Header question to print BIC card
S Y="You have changed this patient's Eligibility."
W *7,!!?40-($L(Y)\2)
W $$S^AGVDF("RVN"),Y,$$S^AGVDF("RVF")
W !!,"Do you want to print a BIC card? N//"
D READ^AG
Q:$D(DFOUT)!$D(DLOUT)!$D(DUOUT)!$D(DTOUT)
NAME ;
S AGNAME=$P(^DPT(DFN,0),U)
I AGNAME="" D G DATERR
. S AGITEM="AGNAME"
S AGSSN=$P(^DPT(DFN,0),U,9)
I AGSSN="" D G DATERR
. S AGITEM="AGSSN"
S AGITEM="DOB"
G:$P(^DPT(DFN,0),U,3)="" DATERR
S AGDOB=$P(^DPT(DFN,0),U,3)
S AGDOB=$$FMTE^XLFDT(AGDOB,"1D")
S AGITEM="SEX"
;IHS/OIT/NKD AG*7.1*11 MU2 - ALLOW FOR PATIENTS WITH UNKNOWN SEX - START NEW CODE
;S AGSEX=$P(^DPT(DFN,0),U,2)
;G:AGSEX=""!("MF"'[AGSEX) DATERR
;S AGSEX=$S(AGSEX="M":"MALE",1:"FEMALE")
S AGSEX=$$GET1^DIQ(2,DFN,.02,"I"),AGSEX=$S(AGSEX="M":"MALE",AGSEX="F":"FEMALE",1:AGSEX)
G:AGSEX="" DATERR
;IHS/OIT/NKD AG*7.1*11 END NEW CODE
;Tribe Name & Facility
S AGITEM="AGTRIBE"
G:'$D(^AUPNPAT(DFN,11)) DATERR
G:$P(^AUPNPAT(DFN,11),U,8)="" DATERR
S AGTRIBE=$P(^AUTTTRI($P(^AUPNPAT(DFN,11),U,8),0),U)
I AGTRIBE="" G DATERR
S AGFACLTY=$P(^DIC(4,DUZ(2),0),U)
I AGFACLTY="" D G DATERR
. S AGITEM="AGFACLTY"
S AGITEM="FACILITY PHONE #"
S AGFACPHN=""
I AGFACPHN="" S AGFACPHN=$P(^AUTTLOC(DUZ(2),0),U,11)
I AGFACPHN="" G DATERR
DT ;
S AGDT=$$FMTE^XLFDT(DT,"1D")
S AGXPHEAD="EXPIRES: "
D EXPIRE
I AGXPIRE="" S AGXPHEAD=""
DEV ;
S %ZIS="OPQ"
D ^%ZIS
I POP D Q
. S IOP=ION
. D ^%ZIS
I $D(IO("Q"))&(($D(IO("S")))!($E(IOST)'="P")) D G DEV
. W *7,!,"Please queue to system printers."
. K IO("Q")
. D ^%ZISC
I $D(IO("Q")) D Q
. K IO("Q")
. X ^%ZOSF("UCI")
. S ZTRTN="PRNTCARD^AGBIC1B"
. S ZTUCI=Y
. S ZTDESC="BIC Card for "_AGNAME_"."
. F G="AGFACLTY","AGFACPHN","AGNAME","AGSSN","AGDT","AGDOB","AGSEX","AGTRIBE","AGXPHEAD","AGXPIRE" S ZTSAVE(G)=""
. D ^%ZTLOAD
. G:'$D(ZTSK) DEV
. K DIR
. S DIR(0)="E"
. S DIR("A")="Task Number = "_ZTSK_" Press RETURN..."
. D ^DIR
. K AG,AGDT,AGDOB,AGSEX,AGXPHEAD,AGXPIRE,AGFACLTY,AGFACPHN,G,AGNAME
. K AGSSN,AGTRIBE,ZTDESC,ZTRTN,ZTSAVE,ZTSK,ZTUCI
. D ^%ZISC
PRNTCARD ;EP - TaskMan.
U IO
W $$S^AGVDF("IOF")
F I=1:1:36 W "*"
W !,"*",?6,"INDIAN HEALTH SERVICE",?35,"*"
W !,"*",?16-($L(AGFACLTY)\2),AGFACLTY,?35,"*"
W !,"*",?16-($L(AGFACPHN)\2),AGFACPHN,?35,"*"
W !,"*",?35,"*",!,"*",?16-($L(AGNAME)\2),AGNAME,?35,"*"
W !,"* SSN: ",$E(AGSSN,1,3),"-",$E(AGSSN,4,5),"-",$E(AGSSN,6,9),?35,"*"
W !,"* DOB: ",AGDOB,?35,"*"
W !,"* SEX: ",AGSEX,?14,"ISSUED: ",AGDT,?35,"*"
W !,"* TRIBE: ",?35,"*",!,"* ",AGTRIBE,?14,?35,"* "
W !,"*",AGXPHEAD,AGXPIRE,?35,"*",! F I=1:1:36 W "*"
D ^%ZISC
Q
DATERR ;Data error processing
W !!,*7,"ERROR IN BIC INFORMATION: '",AGITEM
W "' missing/incorrect.",!,*7,!,"The information must be"
W " supplied/corrected before a card can be printed."
W !,"Press Return..."
D READ^AG
END ;End - close device and kill variables
W $$S^AGVDF("IOF")
D ^%ZISC
K AG,AGDOB,AGDT,AGSEX,DFN,AGXPHEAD,AGXPIRE,AGFACLTY,AGFACPHN
K AGFY,AGITEM,AGNAME,AGSSN,AGTRIBE,X,XY,Y
Q
EXPIRE ;
S AGXPIRE=""
Q:$P(^DPT(DFN,0),U,3)=""
Q:DT-$P(^DPT(DFN,0),U,3)'<180000
Q:$P(^AUPNPAT(DFN,11),U,25)'="Y"
S AGXPIRE=$$FMTE^XLFDT(DT+10000,"1D")
Q
PRNTNOW ;
D PTLK^AG
Q:'$D(DFN)
G NAME
AGBIC1B ; IHS/ASDS/EFG - WRITE BENEFICIARY ID CARD (BIC) ;
+1 ;;7.1;PATIENT REGISTRATION;**11**;AUG 25,2005;Build 1
+2 ;IHS/OIT/NKD AG*7.1*11 MU2 UNKNOWN SEX
+3 ;
START ;Header question to print BIC card
+1 SET Y="You have changed this patient's Eligibility."
+2 WRITE *7,!!?40-($LENGTH(Y)\2)
+3 WRITE $$S^AGVDF("RVN"),Y,$$S^AGVDF("RVF")
+4 WRITE !!,"Do you want to print a BIC card? N//"
+5 DO READ^AG
+6 IF $DATA(DFOUT)!$DATA(DLOUT)!$DATA(DUOUT)!$DATA(DTOUT)
QUIT
NAME ;
+1 SET AGNAME=$PIECE(^DPT(DFN,0),U)
+2 IF AGNAME=""
Begin DoDot:1
+3 SET AGITEM="AGNAME"
End DoDot:1
GOTO DATERR
+4 SET AGSSN=$PIECE(^DPT(DFN,0),U,9)
+5 IF AGSSN=""
Begin DoDot:1
+6 SET AGITEM="AGSSN"
End DoDot:1
GOTO DATERR
+7 SET AGITEM="DOB"
+8 IF $PIECE(^DPT(DFN,0),U,3)=""
GOTO DATERR
+9 SET AGDOB=$PIECE(^DPT(DFN,0),U,3)
+10 SET AGDOB=$$FMTE^XLFDT(AGDOB,"1D")
+11 SET AGITEM="SEX"
+12 ;IHS/OIT/NKD AG*7.1*11 MU2 - ALLOW FOR PATIENTS WITH UNKNOWN SEX - START NEW CODE
+13 ;S AGSEX=$P(^DPT(DFN,0),U,2)
+14 ;G:AGSEX=""!("MF"'[AGSEX) DATERR
+15 ;S AGSEX=$S(AGSEX="M":"MALE",1:"FEMALE")
+16 SET AGSEX=$$GET1^DIQ(2,DFN,.02,"I")
SET AGSEX=$SELECT(AGSEX="M":"MALE",AGSEX="F":"FEMALE",1:AGSEX)
+17 IF AGSEX=""
GOTO DATERR
+18 ;IHS/OIT/NKD AG*7.1*11 END NEW CODE
+19 ;Tribe Name & Facility
+20 SET AGITEM="AGTRIBE"
+21 IF '$DATA(^AUPNPAT(DFN,11))
GOTO DATERR
+22 IF $PIECE(^AUPNPAT(DFN,11),U,8)=""
GOTO DATERR
+23 SET AGTRIBE=$PIECE(^AUTTTRI($PIECE(^AUPNPAT(DFN,11),U,8),0),U)
+24 IF AGTRIBE=""
GOTO DATERR
+25 SET AGFACLTY=$PIECE(^DIC(4,DUZ(2),0),U)
+26 IF AGFACLTY=""
Begin DoDot:1
+27 SET AGITEM="AGFACLTY"
End DoDot:1
GOTO DATERR
+28 SET AGITEM="FACILITY PHONE #"
+29 SET AGFACPHN=""
+30 IF AGFACPHN=""
SET AGFACPHN=$PIECE(^AUTTLOC(DUZ(2),0),U,11)
+31 IF AGFACPHN=""
GOTO DATERR
DT ;
+1 SET AGDT=$$FMTE^XLFDT(DT,"1D")
+2 SET AGXPHEAD="EXPIRES: "
+3 DO EXPIRE
+4 IF AGXPIRE=""
SET AGXPHEAD=""
DEV ;
+1 SET %ZIS="OPQ"
+2 DO ^%ZIS
+3 IF POP
Begin DoDot:1
+4 SET IOP=ION
+5 DO ^%ZIS
End DoDot:1
QUIT
+6 IF $DATA(IO("Q"))&(($DATA(IO("S")))!($EXTRACT(IOST)'="P"))
Begin DoDot:1
+7 WRITE *7,!,"Please queue to system printers."
+8 KILL IO("Q")
+9 DO ^%ZISC
End DoDot:1
GOTO DEV
+10 IF $DATA(IO("Q"))
Begin DoDot:1
+11 KILL IO("Q")
+12 XECUTE ^%ZOSF("UCI")
+13 SET ZTRTN="PRNTCARD^AGBIC1B"
+14 SET ZTUCI=Y
+15 SET ZTDESC="BIC Card for "_AGNAME_"."
+16 FOR G="AGFACLTY","AGFACPHN","AGNAME","AGSSN","AGDT","AGDOB","AGSEX","AGTRIBE","AGXPHEAD","AGXPIRE"
SET ZTSAVE(G)=""
+17 DO ^%ZTLOAD
+18 IF '$DATA(ZTSK)
GOTO DEV
+19 KILL DIR
+20 SET DIR(0)="E"
+21 SET DIR("A")="Task Number = "_ZTSK_" Press RETURN..."
+22 DO ^DIR
+23 KILL AG,AGDT,AGDOB,AGSEX,AGXPHEAD,AGXPIRE,AGFACLTY,AGFACPHN,G,AGNAME
+24 KILL AGSSN,AGTRIBE,ZTDESC,ZTRTN,ZTSAVE,ZTSK,ZTUCI
+25 DO ^%ZISC
End DoDot:1
QUIT
PRNTCARD ;EP - TaskMan.
+1 USE IO
+2 WRITE $$S^AGVDF("IOF")
+3 FOR I=1:1:36
WRITE "*"
+4 WRITE !,"*",?6,"INDIAN HEALTH SERVICE",?35,"*"
+5 WRITE !,"*",?16-($LENGTH(AGFACLTY)\2),AGFACLTY,?35,"*"
+6 WRITE !,"*",?16-($LENGTH(AGFACPHN)\2),AGFACPHN,?35,"*"
+7 WRITE !,"*",?35,"*",!,"*",?16-($LENGTH(AGNAME)\2),AGNAME,?35,"*"
+8 WRITE !,"* SSN: ",$EXTRACT(AGSSN,1,3),"-",$EXTRACT(AGSSN,4,5),"-",$EXTRACT(AGSSN,6,9),?35,"*"
+9 WRITE !,"* DOB: ",AGDOB,?35,"*"
+10 WRITE !,"* SEX: ",AGSEX,?14,"ISSUED: ",AGDT,?35,"*"
+11 WRITE !,"* TRIBE: ",?35,"*",!,"* ",AGTRIBE,?14,?35,"* "
+12 WRITE !,"*",AGXPHEAD,AGXPIRE,?35,"*",!
FOR I=1:1:36
WRITE "*"
+13 DO ^%ZISC
+14 QUIT
DATERR ;Data error processing
+1 WRITE !!,*7,"ERROR IN BIC INFORMATION: '",AGITEM
+2 WRITE "' missing/incorrect.",!,*7,!,"The information must be"
+3 WRITE " supplied/corrected before a card can be printed."
+4 WRITE !,"Press Return..."
+5 DO READ^AG
END ;End - close device and kill variables
+1 WRITE $$S^AGVDF("IOF")
+2 DO ^%ZISC
+3 KILL AG,AGDOB,AGDT,AGSEX,DFN,AGXPHEAD,AGXPIRE,AGFACLTY,AGFACPHN
+4 KILL AGFY,AGITEM,AGNAME,AGSSN,AGTRIBE,X,XY,Y
+5 QUIT
EXPIRE ;
+1 SET AGXPIRE=""
+2 IF $PIECE(^DPT(DFN,0),U,3)=""
QUIT
+3 IF DT-$PIECE(^DPT(DFN,0),U,3)'<180000
QUIT
+4 IF $PIECE(^AUPNPAT(DFN,11),U,25)'="Y"
QUIT
+5 SET AGXPIRE=$$FMTE^XLFDT(DT+10000,"1D")
+6 QUIT
PRNTNOW ;
+1 DO PTLK^AG
+2 IF '$DATA(DFN)
QUIT
+3 GOTO NAME
