BMCRCHK1.m

BMCRCHK1 ; IHS/PHXAO/TMJ - Check Provisional Primary Procedures PX ;

 ;;4.0;REFERRED CARE INFO SYSTEM;;JAN 09, 2006

 ;

 ;This routine checks to insure at least one of the PX's is Primary

 ;If no Primary Px exists or more than one Do PROC OF BMCMOD

 ;to edit existing PX's

 ;

START ;Order through the RCIS PX Gbl

 Q:'$D(^BMCPX("AD",BMCRIEN))

 K BMCPX

 D PXCHK

 D PXMSG

 D END

 Q

 ;

PXCHK ;Check Procedure Entries

 S BMCPXASK=0

 S BMCPXCT=0

 S BMCPX=""

 F  S BMCPX=$O(^BMCPX("AD",BMCRIEN,BMCPX)) Q:BMCPX'=+BMCPX  D

 .I $P(^BMCPX(BMCPX,0),U,5)="P" S BMCPXCT=BMCPXCT+1

 .Q

 Q

PXMSG ;Check if Primary PX Exists

 I BMCPXCT=0 W !!,"WARNING-No Primary Procedure exists for this Referral-Please enter a Primary PX",!,$C(7) H 5 S BMCPXASK=1

 E  I BMCPXCT>1 W !!,"Multiple Primary Procedure exist for this Referral-Only one please",!,$C(7) H 5 S BMCPXASK=1

 ;H 5

 Q

END ;Kill Variables

 K BMCPX,BMCPXIEN,BMCPXCT

 Q

 ;

BMCRCHK1  ; IHS/PHXAO/TMJ - Check Provisional Primary Procedures PX ;

 +1       ;;4.0;REFERRED CARE INFO SYSTEM;;JAN 09, 2006

 +2       ;

 +3       ;This routine checks to insure at least one of the PX's is Primary

 +4       ;If no Primary Px exists or more than one Do PROC OF BMCMOD

 +5       ;to edit existing PX's

 +6       ;

START     ;Order through the RCIS PX Gbl

 +1        IF '$DATA(^BMCPX("AD",BMCRIEN))

               QUIT 

 +2        KILL BMCPX

 +3        DO PXCHK

 +4        DO PXMSG

 +5        DO END

 +6        QUIT 

 +7       ;

PXCHK     ;Check Procedure Entries

 +1        SET BMCPXASK=0

 +2        SET BMCPXCT=0

 +3        SET BMCPX=""

 +4        FOR 

               SET BMCPX=$ORDER(^BMCPX("AD",BMCRIEN,BMCPX))

               IF BMCPX'=+BMCPX

                   QUIT 

               Begin DoDot:1

 +5                IF $PIECE(^BMCPX(BMCPX,0),U,5)="P"

                       SET BMCPXCT=BMCPXCT+1

 +6                QUIT 

               End DoDot:1

 +7        QUIT 

PXMSG     ;Check if Primary PX Exists

 +1        IF BMCPXCT=0

               WRITE !!,"WARNING-No Primary Procedure exists for this Referral-Please enter a Primary PX",!,$CHAR(7)

               HANG 5

               SET BMCPXASK=1

 +2       IF '$TEST

               IF BMCPXCT>1

                   WRITE !!,"Multiple Primary Procedure exist for this Referral-Only one please",!,$CHAR(7)

                   HANG 5

                   SET BMCPXASK=1

 +3       ;H 5

 +4        QUIT 

END       ;Kill Variables

 +1        KILL BMCPX,BMCPXIEN,BMCPXCT

 +2        QUIT 

 +3       ;