APCDEREG.m

APCDEREG ; IHS/CMI/LAB - HS IN DATA ENTRY ;

 ;;2.0;IHS PCC SUITE;;MAY 14, 2009

 ;

 N DIC,DA,D0,X,Y,DP,DI,DL

 I $G(AUPNPAT)="" W !!,$C(7),$C(7),"Sorry I don't know the patient.",! Q

 D GETTYPE

 Q

GETTYPE ;

 S APCDREGT=""

 W !,"The following is a list of registers this patient can be added to."

 W !,"If you choose a CASE MANAGEMENT REGISTER you will be prompted to"

 W !,"enter which of the ",$$CNTCMS," CMS registers to add the patient to.",!

 NEW APCDX,APCDC S (APCDX,APCDC)=0 F  S APCDX=$O(^APCDREGA(APCDX)) Q:APCDX'=+APCDX  D

 .S APCDC=APCDC+1 I $P(^APCDREGA(APCDX,0),U)="CASE MANAGEMENT REGISTER" S APCDYY=APCDC

 .S APCDY(APCDC)=APCDX

 .W !?2,APCDC,") ",$P(^APCDREGA(APCDX,0),U)

 S DIR(0)="N^1:99999:0",DIR("A")="Enter the REGISTER you wish to add "_$P(^DPT(AUPNPAT,0),U)_"  to",DIR("B")="" KILL DA D ^DIR KILL DIR

 I $D(DIRUT) Q

 S APCDREGT=Y

 I Y=APCDYY D CMSREG I APCDCMS="" W !,"CMS Register not selected." G GETTYPE

 X ^APCDREGA(APCDY(APCDREGT),11)

 K APCDYY,APCDY,APCDX,APCDC

 Q

CMSREG ;GET WHICH CMS REGISTER

 W !!

 S APCDCMS=""

 D ^XBFMK

 S DIC("A")="Enter the name of the CASE MANAGEMENT Register: ",DIC="^ACM(41.1,",DIC(0)="AEMQ" D ^DIC

 I Y=-1 D ^XBFMK Q

 S APCDCMS=+Y

 D ^XBFMK

 Q

CMS(PATIENT,REGISTER) ;EP

 I $D(^ACM(41,"AC",PATIENT,REGISTER)) W !!?14,$P(^DPT(PATIENT,0),U)," is already on the ",$P(^ACM(41.1,REGISTER,0),U)," register." Q

 W !!?10,"Adding ",$P(^DPT(PATIENT,0),U),!?13," to the ",$P(^ACM(41.1,REGISTER,0),U)," CMS Register."

 K DIC,DD

 S X=REGISTER,(DIE,DIC)="^ACM(41,",DIC(0)="L",DIC("DR")=".02////"_PATIENT_";1////A;2////"_DT_";4////"_DT

 K DD,DO D FILE^DICN K DIC,DIE,DR,DA

 W !!,$P(^DPT(PATIENT,0),U)," has been added to the ",$P(^ACM(41.1,REGISTER,0),U)," Register."

 Q

ASTHMA(PATIENT) ;

 I $D(^BATREG(PATIENT)) W !!,$P(^DPT(PATIENT,0),U)," is already in the Asthma Register.",! Q

 I $P($G(^BATSITE(DUZ(2),0)),U,7)'=1 W !!

 S (DINUM,X)=PATIENT,DIC(0)="L",DIC="^BATREG(",DIC("DR")=".02///U",DLAYGO=90181.01,DIADD=1 K DD,DO D FILE^DICN K DINUM,DLAYGO,DIADD

 I Y=-1 W !!,"Error encountered when attempting to add this patient to the asthma register." Q

 W !!,$P(^DPT(PATIENT,0),U)," has been added to the Asthma Register."

 ;send bulletin

 K XMB

 S XMB(1)=$P(^DPT(PATIENT,0),U),XMB(2)=$$DOB^AUPNPAT(PATIENT,"E"),XMB(3)=$$HRN^AUPNPAT(PATIENT,DUZ(2)),XMB(4)="",XMB(5)=$$LASTSEV^BATU(PATIENT,5)

 S XMB="BAT NEW PATIENT ON REGISTER"

 D ^XMB K XMB

 Q

WH(PATIENT) ;

 I $P(^DPT(PATIENT,0),U,2)'="F" W !!,"Females Only..." Q

 I $D(^BWP(PATIENT)) W !!,$P(^DPT(PATIENT,0),U)," is already in the WH Register.",! Q

 S (DINUM,X)=PATIENT

 ;---> SET CASE MANAGER DEFAULT.

 N APCDCMGR,DIC

 S APCDCMGR=$S($D(SITE):$P(^BWSITE(SITE,0),U,2),1:"")

 S:'$G(APCDPRMT) APCDPRMT=0

 S DIC("DR")=".1////"_APCDCMGR_";.11///Undetermined;.16///Undetermined"

 S DIC("DR")=DIC("DR")_";.18///Undetermined"

 S DIC("DR")=DIC("DR")_";.2////"_$$CDCID^BWUTL5(PATIENT,DUZ(2))_";.21////"_DT

 K DD,DO S DIC="^BWP(",DIC(0)="ML",DLAYGO=9002086

 D FILE^DICN K DIC

 ;---> IF Y<0, CHECK PERMISSIONS.

 I Y<0,APCDPRMT D  Q

 .W !!?5,"* UNABLE to add this patient to the Women's Health database."

 .W !?5,"  Please contact your site manager to check permissions."

 S Y=+Y

 W !!,$P(^DPT(PATIENT,0),U)," has been added to the Women's Health Register."

 Q

IMM(PATIENT) ;

 I $D(^BIP(PATIENT)) W !!,$P(^DPT(PATIENT,0),U)," is already in the Immunization Register.",! Q

 D AUTOADD^BIPATE(PATIENT,DUZ(2),.ERR)

 I $G(ERR)]"" W !!,ERR Q

 W !!,$P(^DPT(PATIENT,0),U)," has been added to the immunization Register."

 Q

CNTCMS() ;

 NEW X S (X,C)=0 F  S X=$O(^ACM(41.1,X)) Q:X'=+X  S C=C+1

 Q C

APCDEREG  ; IHS/CMI/LAB - HS IN DATA ENTRY ;

 +1       ;;2.0;IHS PCC SUITE;;MAY 14, 2009

 +2       ;

 +3        NEW DIC,DA,D0,X,Y,DP,DI,DL

 +4        IF $GET(AUPNPAT)=""

               WRITE !!,$CHAR(7),$CHAR(7),"Sorry I don't know the patient.",!

               QUIT 

 +5        DO GETTYPE

 +6        QUIT 

GETTYPE   ;

 +1        SET APCDREGT=""

 +2        WRITE !,"The following is a list of registers this patient can be added to."

 +3        WRITE !,"If you choose a CASE MANAGEMENT REGISTER you will be prompted to"

 +4        WRITE !,"enter which of the ",$$CNTCMS," CMS registers to add the patient to.",!

 +5        NEW APCDX,APCDC

           SET (APCDX,APCDC)=0

           FOR 

               SET APCDX=$ORDER(^APCDREGA(APCDX))

               IF APCDX'=+APCDX

                   QUIT 

               Begin DoDot:1

 +6                SET APCDC=APCDC+1

                   IF $PIECE(^APCDREGA(APCDX,0),U)="CASE MANAGEMENT REGISTER"

                       SET APCDYY=APCDC

 +7                SET APCDY(APCDC)=APCDX

 +8                WRITE !?2,APCDC,") ",$PIECE(^APCDREGA(APCDX,0),U)

               End DoDot:1

 +9        SET DIR(0)="N^1:99999:0"

           SET DIR("A")="Enter the REGISTER you wish to add "_$PIECE(^DPT(AUPNPAT,0),U)_"  to"

           SET DIR("B")=""

           KILL DA

           DO ^DIR

           KILL DIR

 +10       IF $DATA(DIRUT)

               QUIT 

 +11       SET APCDREGT=Y

 +12       IF Y=APCDYY

               DO CMSREG

               IF APCDCMS=""

                   WRITE !,"CMS Register not selected."

                   GOTO GETTYPE

 +13       XECUTE ^APCDREGA(APCDY(APCDREGT),11)

 +14       KILL APCDYY,APCDY,APCDX,APCDC

 +15       QUIT 

CMSREG    ;GET WHICH CMS REGISTER

 +1        WRITE !!

 +2        SET APCDCMS=""

 +3        DO ^XBFMK

 +4        SET DIC("A")="Enter the name of the CASE MANAGEMENT Register: "

           SET DIC="^ACM(41.1,"

           SET DIC(0)="AEMQ"

           DO ^DIC

 +5        IF Y=-1

               DO ^XBFMK

               QUIT 

 +6        SET APCDCMS=+Y

 +7        DO ^XBFMK

 +8        QUIT 

CMS(PATIENT,REGISTER) ;EP

 +1        IF $DATA(^ACM(41,"AC",PATIENT,REGISTER))

               WRITE !!?14,$PIECE(^DPT(PATIENT,0),U)," is already on the ",$PIECE(^ACM(41.1,REGISTER,0),U)," register."

               QUIT 

 +2        WRITE !!?10,"Adding ",$PIECE(^DPT(PATIENT,0),U),!?13," to the ",$PIECE(^ACM(41.1,REGISTER,0),U)," CMS Register."

 +3        KILL DIC,DD

 +4        SET X=REGISTER

           SET (DIE,DIC)="^ACM(41,"

           SET DIC(0)="L"

           SET DIC("DR")=".02////"_PATIENT_";1////A;2////"_DT_";4////"_DT

 +5        KILL DD,DO

           DO FILE^DICN

           KILL DIC,DIE,DR,DA

 +6        WRITE !!,$PIECE(^DPT(PATIENT,0),U)," has been added to the ",$PIECE(^ACM(41.1,REGISTER,0),U)," Register."

 +7        QUIT 

ASTHMA(PATIENT) ;

 +1        IF $DATA(^BATREG(PATIENT))

               WRITE !!,$PIECE(^DPT(PATIENT,0),U)," is already in the Asthma Register.",!

               QUIT 

 +2        IF $PIECE($GET(^BATSITE(DUZ(2),0)),U,7)'=1

               WRITE !!

 +3        SET (DINUM,X)=PATIENT

           SET DIC(0)="L"

           SET DIC="^BATREG("

           SET DIC("DR")=".02///U"

           SET DLAYGO=90181.01

           SET DIADD=1

           KILL DD,DO

           DO FILE^DICN

           KILL DINUM,DLAYGO,DIADD

 +4        IF Y=-1

               WRITE !!,"Error encountered when attempting to add this patient to the asthma register."

               QUIT 

 +5        WRITE !!,$PIECE(^DPT(PATIENT,0),U)," has been added to the Asthma Register."

 +6       ;send bulletin

 +7        KILL XMB

 +8        SET XMB(1)=$PIECE(^DPT(PATIENT,0),U)

           SET XMB(2)=$$DOB^AUPNPAT(PATIENT,"E")

           SET XMB(3)=$$HRN^AUPNPAT(PATIENT,DUZ(2))

           SET XMB(4)=""

           SET XMB(5)=$$LASTSEV^BATU(PATIENT,5)

 +9        SET XMB="BAT NEW PATIENT ON REGISTER"

 +10       DO ^XMB

           KILL XMB

 +11       QUIT 

WH(PATIENT) ;

 +1        IF $PIECE(^DPT(PATIENT,0),U,2)'="F"

               WRITE !!,"Females Only..."

               QUIT 

 +2        IF $DATA(^BWP(PATIENT))

               WRITE !!,$PIECE(^DPT(PATIENT,0),U)," is already in the WH Register.",!

               QUIT 

 +3        SET (DINUM,X)=PATIENT

 +4       ;---> SET CASE MANAGER DEFAULT.

 +5        NEW APCDCMGR,DIC

 +6        SET APCDCMGR=$SELECT($DATA(SITE):$PIECE(^BWSITE(SITE,0),U,2),1:"")

 +7        IF '$GET(APCDPRMT)

               SET APCDPRMT=0

 +8        SET DIC("DR")=".1////"_APCDCMGR_";.11///Undetermined;.16///Undetermined"

 +9        SET DIC("DR")=DIC("DR")_";.18///Undetermined"

 +10       SET DIC("DR")=DIC("DR")_";.2////"_$$CDCID^BWUTL5(PATIENT,DUZ(2))_";.21////"_DT

 +11       KILL DD,DO

           SET DIC="^BWP("

           SET DIC(0)="ML"

           SET DLAYGO=9002086

 +12       DO FILE^DICN

           KILL DIC

 +13      ;---> IF Y<0, CHECK PERMISSIONS.

 +14       IF Y<0

               IF APCDPRMT

                   Begin DoDot:1

 +15                   WRITE !!?5,"* UNABLE to add this patient to the Women's Health database."

 +16                   WRITE !?5,"  Please contact your site manager to check permissions."

                   End DoDot:1

                   QUIT 

 +17       SET Y=+Y

 +18       WRITE !!,$PIECE(^DPT(PATIENT,0),U)," has been added to the Women's Health Register."

 +19       QUIT 

IMM(PATIENT) ;

 +1        IF $DATA(^BIP(PATIENT))

               WRITE !!,$PIECE(^DPT(PATIENT,0),U)," is already in the Immunization Register.",!

               QUIT 

 +2        DO AUTOADD^BIPATE(PATIENT,DUZ(2),.ERR)

 +3        IF $GET(ERR)]""

               WRITE !!,ERR

               QUIT 

 +4        WRITE !!,$PIECE(^DPT(PATIENT,0),U)," has been added to the immunization Register."

 +5        QUIT 

CNTCMS()  ;

 +1        NEW X

           SET (X,C)=0

           FOR 

               SET X=$ORDER(^ACM(41.1,X))

               IF X'=+X

                   QUIT 

               SET C=C+1

 +2        QUIT C