AGCARD ; IHS/ASDS/EFG - EMBOSSED CARD ;
;;7.1;PATIENT REGISTRATION;**4,11**;AUG 25,2005;Build 1
;IHS/OIT/NKD AG*7.1*11 MU2 UNKNOWN SEX
D PTLK^AG
DFN ;EP - With a Pre-defined DFN.
Q:'$D(DFN)!$D(DUOUT)!$D(DFOUT)!$D(DTOUT)
I $E($P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,2))="T" D Q
. W !,"EMBOSSED CARD CANNOT BE PRINTED DUE TO TEMPORARY CHART NUMBER"
. D END
G COPIES:AGOPT(19)="Y"
D ^AGDATCK S:'$D(AGV("DTOT")) AGV("DTOT")=0
G COPIES:AGV("DTOT")=0
F AG=8,9 I $D(AGV("ER",AG)) S AGV("DTOT")=AGV("DTOT")-1
I AGOPT(14)'="Y",$D(AGV("ER",12)) S AGV("DTOT")=AGV("DTOT")-1
G PRERR:AGV("DTOT")>0
COPIES W !!!,"How many copies of the EMBOSSED CARD do you want? (1-5) 1// "
D READ^AG S:$D(DLOUT) Y=1 Q:Y=""
I +Y<1!(+Y>5) W !!,*7,"Enter a number from 1 through 5.",!! G COPIES
S AGCOPY=+Y
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^AGCARD",ZTUCI=Y,ZTDESC="Embossed Card for "_$P($G(^DPT(DFN,0)),U)_"." F G="AGCOPY","DFN" S ZTSAVE(G)=""
D ^%ZTLOAD G:'$D(ZTSK) DEV K AG,AGCOPY,G,ZTDESC,ZTRTN,ZTSAVE,ZTSK,ZTUCI D ^%ZISC
Q
PRERR W $$S^AGVDF("IOF")
W "EMBOSSED CARD CANNOT BE PRINTED DUE TO MISSING or "
W "INVALID MANDATORY DATA:",!!
D ^AGBADATA
G END
START ;EP - TaskMan.
D:'$D(AGOPT) ^AGVAR G:AGOPT(19)="Y" PRINT
S AGNAME=$E($P($G(^DPT(DFN,0)),U),1,28)
S AGDOB=$P($G(^DPT(DFN,0)),U,3)
S Y=AGDOB D DD^%DT
S AGDOB=Y
;IHS/OIT/NKD AG*7.1*11 MU2 - ALLOW FOR PATIENTS WITH UNKNOWN SEX - DISPLAYS 'U'
;S AGSEX=$P($G(^DPT(DFN,0)),U,2),AGSEX=$S(AGSEX="F":2,1:1)
S AGSEX=$$GET1^DIQ(2,DFN,.02,"I"),AGSEX=$S(AGSEX="F":2,AGSEX="M":1,AGSEX="U":"U",1:1)
;S AGSSN=$P($G(^DPT(DFN,0)),U,9)
;S:$L(AGSSN)=9 AGSSN=$E(AGSSN,1,3)_"-"_$E(AGSSN,4,5)_"-"_$E(AGSSN,6,9)
S AGSSN=$$GET1^DIQ(9000001,DFN_",",1107.3) ;IHS/SD/TPF AG*7.1*4
S AGFAC=^AUTTLOC(DUZ(2),0),AGFAC=$S($P(AGFAC,U,2)]"":$P(AGFAC,U,2),1:$P($G(^DIC(4,DUZ(2),0)),U)),AGFAC=$E(AGFAC,1,28)
S X=$P($G(^AUPNPAT(DFN,41,DUZ(2),0)),U,2) S:$L(X)<6 X=$E("000000",1,(6-$L(X)))_X S AGCHART=X
TRBCD I $E(AGCHART,1)="T" D Q
. I '$D(ZTQUEUED) D
.. W !,"EMBOSSED CARD CANNOT BE PRINTED DUE TO TEMPORARY CHART NUMBER"
. D END
. Q
S AG("TRBCODE")=$S(+$P($G(^AUPNPAT(DFN,11)),U,8):$P($G(^AUTTTRI(+$P($G(^AUPNPAT(DFN,11)),U,8),0)),U,2),1:"999"),AGTRQNT=$P($G(^AUPNPAT(DFN,11)),U,9)
S AGBLDCD=$S(AGTRQNT="FULL":"001",AGTRQNT="NONE":"005",AGTRQNT="UNSPECIFIED":"006",AGTRQNT="UNKNOWN":"007",1:"000") D FRACT:AGBLDCD="000"&(AGTRQNT["/")
S DIC=9000001.51,DA=DFN,DR=.03,AG("DRENT")=0 D ^AGDICLK S AGCOMCD="UNKNOWN" I $D(AG("LKDATA")),AG("LKDATA")]"",$D(^AUTTCOM(AG("LKDATA"),0)) S AGCOMCD=$P($G(^(0)),U,8),AGCOMCD=$E(AGCOMCD,5,8)_"-"_$E(AGCOMCD,3,4)_"-"_$E(AGCOMCD,1,2)
PRINT U IO F AG=1:1:AGCOPY W "<" D FORMPRT:AGOPT(19)="Y",CARDP:AGOPT(19)'="Y" W ">",@IOF
END D ^%ZISC
K AG,AGDOB,AGSEX,AGSSN,AGBLDCD,AGCHART,AGCOMCD,AGCOPY,AGE("CPOS"),DA,DIC,DR,AGFAC,AGLINE,AGLINITM,AG("LKDATA"),AG("LKERR"),AG("LKPRINT"),AGMES,AGNAME,AGOPTRNS,AGV("SFN"),AGV("SFFN"),AG("TRBCODE"),AGTRQNT,X D:$D(ZTQUEUED) KILL^%ZTLOAD
Q
CARDP ;Print an ID Card.
W !!,AGFAC,!!,"(",AGCHART,") ",AGSSN,!!,AGNAME,!,AGDOB," "
W AGSEX," ",AG("TRBCODE")," ",AGBLDCD,!," ",AGCOMCD
Q
FRACT Q:+$P(AGTRQNT,"/",2)=0 S AG=$P(AGTRQNT,"/",1)/$P(AGTRQNT,"/",2)
I AG'<1 S AGBLDCD="001" Q
I AG'<.5 S AGBLDCD="002" Q
I AG'<.25 S AGBLDCD="003" Q
S AGBLDCD="004"
Q
FORMPRT ;Use this code if the site selects to set their own card format.
F AGLINE=0:0 S AGLINE=$O(^AGFAC(DUZ(2),99,AGLINE)) Q:'AGLINE F AG("CHRPOS")=0:0 S AG("CHRPOS")=$O(^AGFAC(DUZ(2),99,AGLINE,1,AG("CHRPOS"))) W:'AG("CHRPOS") ! Q:'AG("CHRPOS") D PRNTITEM
K ^UTILITY("DIQ1",$J)
Q
PRNTITEM K ^UTILITY("DIQ1",$J)
K DR,DA,AGV,AGE
S AGE("CPOS")=$P($G(^AGFAC(DUZ(2),99,AGLINE,1,AG("CHRPOS"),0)),U),AG0=$G(^(0)),AG2=$G(^(2)),DIC=$P($G(^(0)),U,2),DR=$P($G(^(0)),U,3),AGV("SFN")=$P($G(^(0)),U,4),AGV("SFFN")=$P($G(^(0)),U,5),AGE("MES1")=$P($G(^(0)),U,6),AGITPOTR="",DA=DFN
Q:DA=""!(DIC="")!(DR="")
S AGE("MES2")=$P(AG0,U,7),AGE("IEN1")=$P(AG2,U,2),AGE("IEN2")=$P(AG2,U,3)
S DA=$S(AGE("MES1")="DUZ(2)":DUZ(2),AGE("MES1")="IEN1":AGE("IEN1"),1:DFN)
I AGV("SFN")]"" S DR(AGV("SFN"))=AGV("SFFN"),DA(AGV("SFN"))=$S(AGE("MES2")="DUZ(2)":DUZ(2),AGE("MES2")="IEN2":AGE("IEN2"),1:DFN)
I $D(^AGFAC(DUZ(2),99,AGLINE,1,AG("CHRPOS"),1)) S AGITPOTR=^(1)
W ?AGE("CPOS") D EN^DIQ1 S:AGV("SFN")]"" DR=AGV("SFFN")
I $G(AGV("SFN"))="",DIC["(" S DIC=+$P(@(DIC_"0)"),"^",2)
I $G(AGV("SFN"))'="" S DIC=AGV("SFN"),DA=DA(AGV("SFN"))
I $D(^UTILITY("DIQ1",$J,DIC,DA,DR)) S X=^(DR) X:AGITPOTR]"" AGITPOTR W X
K AGE,DR,DA,AGV,AG0,AG2,AGITPOTR
Q
AGCARD ; IHS/ASDS/EFG - EMBOSSED CARD ;
+1 ;;7.1;PATIENT REGISTRATION;**4,11**;AUG 25,2005;Build 1
+2 ;IHS/OIT/NKD AG*7.1*11 MU2 UNKNOWN SEX
+3 DO PTLK^AG
DFN ;EP - With a Pre-defined DFN.
+1 IF '$DATA(DFN)!$DATA(DUOUT)!$DATA(DFOUT)!$DATA(DTOUT)
QUIT
+2 IF $EXTRACT($PIECE($GET(^AUPNPAT(DFN,41,DUZ(2),0)),U,2))="T"
Begin DoDot:1
+3 WRITE !,"EMBOSSED CARD CANNOT BE PRINTED DUE TO TEMPORARY CHART NUMBER"
+4 DO END
End DoDot:1
QUIT
+5 IF AGOPT(19)="Y"
GOTO COPIES
+6 DO ^AGDATCK
IF '$DATA(AGV("DTOT"))
SET AGV("DTOT")=0
+7 IF AGV("DTOT")=0
GOTO COPIES
+8 FOR AG=8,9
IF $DATA(AGV("ER",AG))
SET AGV("DTOT")=AGV("DTOT")-1
+9 IF AGOPT(14)'="Y"
IF $DATA(AGV("ER",12))
SET AGV("DTOT")=AGV("DTOT")-1
+10 IF AGV("DTOT")>0
GOTO PRERR
COPIES WRITE !!!,"How many copies of the EMBOSSED CARD do you want? (1-5) 1// "
+1 DO READ^AG
IF $DATA(DLOUT)
SET Y=1
IF Y=""
QUIT
+2 IF +Y<1!(+Y>5)
WRITE !!,*7,"Enter a number from 1 through 5.",!!
GOTO COPIES
+3 SET AGCOPY=+Y
DEV SET %ZIS="OPQ"
DO ^%ZIS
IF POP
SET IOP=ION
DO ^%ZIS
QUIT
+1 IF '$DATA(IO("Q"))
GOTO START
KILL IO("Q")
+2 IF $DATA(IO("S"))!($EXTRACT(IOST)'="P")
WRITE *7,!,"Please queue to system printers."
DO ^%ZISC
GOTO DEV
+3 XECUTE ^%ZOSF("UCI")
SET ZTRTN="START^AGCARD"
SET ZTUCI=Y
SET ZTDESC="Embossed Card for "_$PIECE($GET(^DPT(DFN,0)),U)_"."
FOR G="AGCOPY","DFN"
SET ZTSAVE(G)=""
+4 DO ^%ZTLOAD
IF '$DATA(ZTSK)
GOTO DEV
KILL AG,AGCOPY,G,ZTDESC,ZTRTN,ZTSAVE,ZTSK,ZTUCI
DO ^%ZISC
+5 QUIT
PRERR WRITE $$S^AGVDF("IOF")
+1 WRITE "EMBOSSED CARD CANNOT BE PRINTED DUE TO MISSING or "
+2 WRITE "INVALID MANDATORY DATA:",!!
+3 DO ^AGBADATA
+4 GOTO END
START ;EP - TaskMan.
+1 IF '$DATA(AGOPT)
DO ^AGVAR
IF AGOPT(19)="Y"
GOTO PRINT
+2 SET AGNAME=$EXTRACT($PIECE($GET(^DPT(DFN,0)),U),1,28)
+3 SET AGDOB=$PIECE($GET(^DPT(DFN,0)),U,3)
+4 SET Y=AGDOB
DO DD^%DT
+5 SET AGDOB=Y
+6 ;IHS/OIT/NKD AG*7.1*11 MU2 - ALLOW FOR PATIENTS WITH UNKNOWN SEX - DISPLAYS 'U'
+7 ;S AGSEX=$P($G(^DPT(DFN,0)),U,2),AGSEX=$S(AGSEX="F":2,1:1)
+8 SET AGSEX=$$GET1^DIQ(2,DFN,.02,"I")
SET AGSEX=$SELECT(AGSEX="F":2,AGSEX="M":1,AGSEX="U":"U",1:1)
+9 ;S AGSSN=$P($G(^DPT(DFN,0)),U,9)
+10 ;S:$L(AGSSN)=9 AGSSN=$E(AGSSN,1,3)_"-"_$E(AGSSN,4,5)_"-"_$E(AGSSN,6,9)
+11 ;IHS/SD/TPF AG*7.1*4
SET AGSSN=$$GET1^DIQ(9000001,DFN_",",1107.3)
+12 SET AGFAC=^AUTTLOC(DUZ(2),0)
SET AGFAC=$SELECT($PIECE(AGFAC,U,2)]"":$PIECE(AGFAC,U,2),1:$PIECE($GET(^DIC(4,DUZ(2),0)),U))
SET AGFAC=$EXTRACT(AGFAC,1,28)
+13 SET X=$PIECE($GET(^AUPNPAT(DFN,41,DUZ(2),0)),U,2)
IF $LENGTH(X)<6
SET X=$EXTRACT("000000",1,(6-$LENGTH(X)))_X
SET AGCHART=X
TRBCD IF $EXTRACT(AGCHART,1)="T"
Begin DoDot:1
+1 IF '$DATA(ZTQUEUED)
Begin DoDot:2
+2 WRITE !,"EMBOSSED CARD CANNOT BE PRINTED DUE TO TEMPORARY CHART NUMBER"
End DoDot:2
+3 DO END
+4 QUIT
End DoDot:1
QUIT
+5 SET AG("TRBCODE")=$SELECT(+$PIECE($GET(^AUPNPAT(DFN,11)),U,8):$PIECE($GET(^AUTTTRI(+$PIECE($GET(^AUPNPAT(DFN,11)),U,8),0)),U,2),1:"999")
SET AGTRQNT=$PIECE($GET(^AUPNPAT(DFN,11)),U,9)
+6 SET AGBLDCD=$SELECT(AGTRQNT="FULL":"001",AGTRQNT="NONE":"005",AGTRQNT="UNSPECIFIED":"006",AGTRQNT="UNKNOWN":"007",1:"000")
IF AGBLDCD="000"&(AGTRQNT["/")
DO FRACT
+7 SET DIC=9000001.51
SET DA=DFN
SET DR=.03
SET AG("DRENT")=0
DO ^AGDICLK
SET AGCOMCD="UNKNOWN"
IF $DATA(AG("LKDATA"))
IF AG("LKDATA")]""
IF $DATA(^AUTTCOM(AG("LKDATA"),0))
SET AGCOMCD=$PIECE($GET(^(0)),U,8)
SET AGCOMCD=$EXTRACT(AGCOMCD,5,8)_"-"_$EXTRACT(AGCOMCD,3,4)_"-"_$EXTRACT(AGCOMCD,1,2)
PRINT USE IO
FOR AG=1:1:AGCOPY
WRITE "<"
IF AGOPT(19)="Y"
DO FORMPRT
IF AGOPT(19)'="Y"
DO CARDP
WRITE ">",@IOF
END DO ^%ZISC
+1 KILL AG,AGDOB,AGSEX,AGSSN,AGBLDCD,AGCHART,AGCOMCD,AGCOPY,AGE("CPOS"),DA,DIC,DR,AGFAC,AGLINE,AGLINITM,AG("LKDATA"),AG("LKERR"),AG("LKPRINT"),AGMES,AGNAME,AGOPTRNS,AGV("SFN"),AGV("SFFN"),AG("TRBCODE"),AGTRQNT,X
IF $DATA(ZTQUEUED)
DO KILL^%ZTLOAD
+2 QUIT
CARDP ;Print an ID Card.
+1 WRITE !!,AGFAC,!!,"(",AGCHART,") ",AGSSN,!!,AGNAME,!,AGDOB," "
+2 WRITE AGSEX," ",AG("TRBCODE")," ",AGBLDCD,!," ",AGCOMCD
+3 QUIT
FRACT IF +$PIECE(AGTRQNT,"/",2)=0
QUIT
SET AG=$PIECE(AGTRQNT,"/",1)/$PIECE(AGTRQNT,"/",2)
+1 IF AG'<1
SET AGBLDCD="001"
QUIT
+2 IF AG'<.5
SET AGBLDCD="002"
QUIT
+3 IF AG'<.25
SET AGBLDCD="003"
QUIT
+4 SET AGBLDCD="004"
+5 QUIT
FORMPRT ;Use this code if the site selects to set their own card format.
+1 FOR AGLINE=0:0
SET AGLINE=$ORDER(^AGFAC(DUZ(2),99,AGLINE))
IF 'AGLINE
QUIT
FOR AG("CHRPOS")=0:0
SET AG("CHRPOS")=$ORDER(^AGFAC(DUZ(2),99,AGLINE,1,AG("CHRPOS")))
IF 'AG("CHRPOS")
WRITE !
IF 'AG("CHRPOS")
QUIT
DO PRNTITEM
+2 KILL ^UTILITY("DIQ1",$JOB)
+3 QUIT
PRNTITEM KILL ^UTILITY("DIQ1",$JOB)
+1 KILL DR,DA,AGV,AGE
+2 SET AGE("CPOS")=$PIECE($GET(^AGFAC(DUZ(2),99,AGLINE,1,AG("CHRPOS"),0)),U)
SET AG0=$GET(^(0))
SET AG2=$GET(^(2))
SET DIC=$PIECE($GET(^(0)),U,2)
SET DR=$PIECE($GET(^(0)),U,3)
SET AGV("SFN")=$PIECE($GET(^(0)),U,4)
SET AGV("SFFN")=$PIECE($GET(^(0)),U,5)
SET AGE("MES1")=$PIECE($GET(^(0)),U,6)
SET AGITPOTR=""
SET DA=DFN
+3 IF DA=""!(DIC="")!(DR="")
QUIT
+4 SET AGE("MES2")=$PIECE(AG0,U,7)
SET AGE("IEN1")=$PIECE(AG2,U,2)
SET AGE("IEN2")=$PIECE(AG2,U,3)
+5 SET DA=$SELECT(AGE("MES1")="DUZ(2)":DUZ(2),AGE("MES1")="IEN1":AGE("IEN1"),1:DFN)
+6 IF AGV("SFN")]""
SET DR(AGV("SFN"))=AGV("SFFN")
SET DA(AGV("SFN"))=$SELECT(AGE("MES2")="DUZ(2)":DUZ(2),AGE("MES2")="IEN2":AGE("IEN2"),1:DFN)
+7 IF $DATA(^AGFAC(DUZ(2),99,AGLINE,1,AG("CHRPOS"),1))
SET AGITPOTR=^(1)
+8 WRITE ?AGE("CPOS")
DO EN^DIQ1
IF AGV("SFN")]""
SET DR=AGV("SFFN")
+9 IF $GET(AGV("SFN"))=""
IF DIC["("
SET DIC=+$PIECE(@(DIC_"0)"),"^",2)
+10 IF $GET(AGV("SFN"))'=""
SET DIC=AGV("SFN")
SET DA=DA(AGV("SFN"))
+11 IF $DATA(^UTILITY("DIQ1",$JOB,DIC,DA,DR))
SET X=^(DR)
IF AGITPOTR]""
XECUTE AGITPOTR
WRITE X
+12 KILL AGE,DR,DA,AGV,AG0,AG2,AGITPOTR
+13 QUIT
