Routine: AGCARD

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

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

CARDP ;Print an ID Card.

 W !!,AGFAC,!!,"(",AGCHART,")       ",AGSSN,!!,AGNAME,!,AGDOB,"   "

 W AGSEX,"  ",AG("TRBCODE"),"  ",AGBLDCD,!,"                  ",AGCOMCD

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"

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)

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

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

AGCARD.m