Routine: BMCFDR3

BMCFDR3 ; IHS/PHXAO/TMJ - DRIVER TO RE-PRINT/EDIT/DELETE SECONDARY PROVIDER LETTER ;

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

 ;IHS/ITSC/FCJ CHG VAR NAME AND ADDED VARS TO KILL

 ;This is the Main Driver Routine -

 ;RCIS REPORT OUTPUT DEFINITION - SECONDARY PROVIDER LETTER

 ;Calls PRINT ROUTINE BMCFPRN3

 ;After User Input of data - RCIS SECONDARY PROVIDER FILE

 ;is populated with data ^BMCPROV( Global

START ;

 S BMCCPRV="",BMCAPDT="",BMCAPUR=""

 W:$D(IOF) @IOF

 W "**********  REFERRAL FORM PRINT-SECONDARY PROVIDER  **********",!!

 W "This option will produce a hard copy computer generated",!,"-Existing Secondary Provider Letter",!

 W "You can also edit or delete an existing Secondary Provider Letter.",!!

 S BMCQUIT=0

 S BMCPROV=""

 S BMCCPRV="" ;Secondary Provider Name

 S BMCAPPDT="" ;Secondary Provider Appointment Date

 S BMCAPUR="" ;Secondary Provider Purpose of Appointment

 S BMCKIND=0 ; Determines if Type of Referral=IHS

GETREF ;get referral entry

 S DIR(0)="S^1:STANDARD;2:AHCCCS",DIR("A")="Enter Secondary Letter Type",DIR("B")="STANDARD",DIR("?")="Enter Letter Form Output Choice" KILL DA D ^DIR KILL DIR

 I $D(DIRUT) G XIT

 S BMCHOICE=Y

 S BMCFTYPE=$S(BMCHOICE=1:5,BMCHOICE=2:7,1:5)

 W !! S BMCREF=""

 S DIC="^BMCPROV(",DIC(0)="AEMQ",DIC("A")="Select Secondary Letter by Patient Name or Date of Letter: " D ^DIC K DA,DIC

 G:Y=-1 XIT

 S BMCPROV=+Y

 Q:'BMCPROV

 I $D(^BMCTFORM(BMCFTYPE,11)) X ^BMCTFORM(BMCFTYPE,11) G:BMCQUIT GETREF

 S BMCREF=$P($G(^BMCPROV(BMCPROV,0)),U,3)

 Q:BMCREF=""

 I $P($G(^BMCREF(BMCREF,0)),U,4)="N" W !!,?10,"In-House Reerrals are not allowed with this Menu Option",!! G GETREF

GETLTR ;Select the desired Secondary Letter to edit - print - delete

 ;IHS Type

 I $P($G(^BMCREF(BMCREF,0)),U,4)="I" D

 . S BMCCPRV=$P($G(^BMCPROV(BMCPROV,0)),U,8)

 . Q:BMCCPRV=""

 . S BMCCPRVP=$P($G(^DIC(4,BMCCPRV,0)),U)

 . Q:BMCCPRVP=""

 . S BMCKIND=1

 ;CHS or Other Types

 I BMCKIND=1 G TYPE

 S BMCCPRV=$P($G(^BMCPROV(BMCPROV,0)),U,5) ; GET 2ND PROVIDER

 I BMCCPRV="" W !!,?10,"**Secondary Provider Data Missing on Letter**!!" Q

 S BMCCPRVP=$P($G(^AUTTVNDR(BMCCPRV,0)),U) ;GET ACTUAL PROVIDER NAME

TYPE ;Get Remaining Provider Data

 S BMCAPPDT=$P($G(^BMCPROV(BMCPROV,0)),U,6) ;GET EXPT APPT DT

 S BMCAPUR=$P($G(^BMCPROV(BMCPROV,0)),U,7) ;GET PURPOSE

ZIS ;

 W !! S XBRC="COMP^BMCFDR3",XBRP="PRINT^BMCFDR3",XBNS="BMC",XBRX="XIT^BMCFDR3"

 D ^XBDBQUE

PRINT ;EP

 X:$D(^BMCTFORM(BMCFTYPE,12)) ^BMCTFORM(BMCFTYPE,12)

XIT ;

 K BMCCAP,BMCCHSR,BMCDA,BMCFILE,BMCFTYPE,BMCIOM,BMCKPDA,BMCNODE,BMCPG,BMCQUIT,BMCR0,BMCREF,BMCRNS,BMCV,BMCWP,BMCX,BMCY,BMCI,BMCDFN,BMCCHSAS

 K A,C,D,D0,D1,DA,DD,DDSFILE,DI,DIADD,DIC,DICR,DIE,DIK,DINUM,DIPGM,DIQ,DIR,DIWF,DIWL,DIWR,DLAYGO,DO,DQ,DR,DTOUT,F,G,I,J,N,P,T,X,Y,Z

 K BMCPROUT,BMCN,BMCNUM,BMCAGE,BMCFIRST,BMCLAST,BMCLTYP,BMCDTIEN,BMCCPRV,BMCAPPDT,BMCAPUR,BMCDTIEN

 K BMCPROV,BMCAPDT,BMCQUIT,BMCCPRV,BMCCPRVP,BMCAPUR,BMCFTYPE,BMCREF,BMCDT,BMCAPPDT,BMCKIND,BMCHOICE,BMCTYPE

 K BMCCMT

COMP ;

WP ;EP - Entry point to print wp fields pass node in BMCWP

 ;PASS FILE IN BMCFILE, ENTRY IN BMCREF

 NEW G,P,BMCX

 K BMCWP

 K ^UTILITY($J,"W")

 S BMCX=0,P=0

 S G=$S($G(G)]"":G,1:^DIC(BMCFILE,0,"GL")),G=G_BMCDA_","_BMCNODE_",BMCX)"

 S DIWR=$S($G(BMCIOM):BMCIOM,1:IOM),DIWL=0 F  S BMCX=$O(@G) Q:BMCX'=+BMCX  D

 .S Y=$P(G,")")_",0)"

 .S X="" I $G(BMCCAP)]"",BMCX=1 S X=BMCCAP

 .S X=X_@Y D ^DIWP

WPS ;EP

 S Z=0 F  S Z=$O(^UTILITY($J,"W",DIWL,Z)) Q:Z'=+Z  S P=P+1,BMCWP(P)=^UTILITY($J,"W",DIWL,Z,0)

 K DIWL,DIWR,DIWF,Z

 K ^UTILITY($J,"W"),BMCNODE,BMCFILE,BMCDA,G,BMCCOL,BMCCAP

BMCFDR3   ; IHS/PHXAO/TMJ - DRIVER TO RE-PRINT/EDIT/DELETE SECONDARY PROVIDER LETTER ;

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

 +2       ;IHS/ITSC/FCJ CHG VAR NAME AND ADDED VARS TO KILL

 +3       ;

 +4       ;This is the Main Driver Routine -

 +5       ;RCIS REPORT OUTPUT DEFINITION - SECONDARY PROVIDER LETTER

 +6       ;Calls PRINT ROUTINE BMCFPRN3

 +7       ;After User Input of data - RCIS SECONDARY PROVIDER FILE

 +8       ;is populated with data ^BMCPROV( Global

 +9       ;

START     ;

 +1        SET BMCCPRV=""

           SET BMCAPDT=""

           SET BMCAPUR=""

 +2        IF $DATA(IOF)

               WRITE @IOF

 +3        WRITE "**********  REFERRAL FORM PRINT-SECONDARY PROVIDER  **********",!!

 +4        WRITE "This option will produce a hard copy computer generated",!,"-Existing Secondary Provider Letter",!

 +5        WRITE "You can also edit or delete an existing Secondary Provider Letter.",!!

 +6        SET BMCQUIT=0

 +7        SET BMCPROV=""

 +8       ;Secondary Provider Name

           SET BMCCPRV=""

 +9       ;Secondary Provider Appointment Date

           SET BMCAPPDT=""

 +10      ;Secondary Provider Purpose of Appointment

           SET BMCAPUR=""

 +11      ; Determines if Type of Referral=IHS

           SET BMCKIND=0

GETREF    ;get referral entry

 +1       ;

 +2        SET DIR(0)="S^1:STANDARD;2:AHCCCS"

           SET DIR("A")="Enter Secondary Letter Type"

           SET DIR("B")="STANDARD"

           SET DIR("?")="Enter Letter Form Output Choice"

           KILL DA

           DO ^DIR

           KILL DIR

 +3        IF $DATA(DIRUT)

               GOTO XIT

 +4        SET BMCHOICE=Y

 +5        SET BMCFTYPE=$SELECT(BMCHOICE=1:5,BMCHOICE=2:7,1:5)

 +6       ;

 +7        WRITE !!

           SET BMCREF=""

 +8        SET DIC="^BMCPROV("

           SET DIC(0)="AEMQ"

           SET DIC("A")="Select Secondary Letter by Patient Name or Date of Letter: "

           DO ^DIC

           KILL DA,DIC

 +9        IF Y=-1

               GOTO XIT

 +10       SET BMCPROV=+Y

 +11       IF 'BMCPROV

               QUIT

 +12       IF $DATA(^BMCTFORM(BMCFTYPE,11))

               XECUTE ^BMCTFORM(BMCFTYPE,11)

               IF BMCQUIT

                   GOTO GETREF

 +13       SET BMCREF=$PIECE($GET(^BMCPROV(BMCPROV,0)),U,3)

 +14       IF BMCREF=""

               QUIT

 +15       IF $PIECE($GET(^BMCREF(BMCREF,0)),U,4)="N"

               WRITE !!,?10,"In-House Reerrals are not allowed with this Menu Option",!!

               GOTO GETREF

 +16      ;

GETLTR    ;Select the desired Secondary Letter to edit - print - delete

 +1       ;

 +2       ;IHS Type

 +3        IF $PIECE($GET(^BMCREF(BMCREF,0)),U,4)="I"

               Begin DoDot:1

 +4                SET BMCCPRV=$PIECE($GET(^BMCPROV(BMCPROV,0)),U,8)

 +5                IF BMCCPRV=""

                       QUIT

 +6                SET BMCCPRVP=$PIECE($GET(^DIC(4,BMCCPRV,0)),U)

 +7                IF BMCCPRVP=""

                       QUIT

 +8                SET BMCKIND=1

               End DoDot:1

 +9       ;

 +10      ;CHS or Other Types

 +11       IF BMCKIND=1

               GOTO TYPE

 +12      ; GET 2ND PROVIDER

           SET BMCCPRV=$PIECE($GET(^BMCPROV(BMCPROV,0)),U,5)

 +13       IF BMCCPRV=""

               WRITE !!,?10,"**Secondary Provider Data Missing on Letter**!!"

               QUIT

 +14      ;GET ACTUAL PROVIDER NAME

           SET BMCCPRVP=$PIECE($GET(^AUTTVNDR(BMCCPRV,0)),U)

 +15      ;

TYPE      ;Get Remaining Provider Data

 +1       ;

 +2       ;GET EXPT APPT DT

           SET BMCAPPDT=$PIECE($GET(^BMCPROV(BMCPROV,0)),U,6)

 +3       ;GET PURPOSE

           SET BMCAPUR=$PIECE($GET(^BMCPROV(BMCPROV,0)),U,7)

ZIS       ;

 +1        WRITE !!

           SET XBRC="COMP^BMCFDR3"

           SET XBRP="PRINT^BMCFDR3"

           SET XBNS="BMC"

           SET XBRX="XIT^BMCFDR3"

 +2        DO ^XBDBQUE

 +3        QUIT

 +4       ;

PRINT     ;EP

 +1        IF $DATA(^BMCTFORM(BMCFTYPE,12))

               XECUTE ^BMCTFORM(BMCFTYPE,12)

 +2        QUIT

XIT       ;

 +1        KILL BMCCAP,BMCCHSR,BMCDA,BMCFILE,BMCFTYPE,BMCIOM,BMCKPDA,BMCNODE,BMCPG,BMCQUIT,BMCR0,BMCREF,BMCRNS,BMCV,BMCWP,BMCX,BMCY,BMCI,BMCDFN,BMCCHSAS

 +2        KILL A,C,D,D0,D1,DA,DD,DDSFILE,DI,DIADD,DIC,DICR,DIE,DIK,DINUM,DIPGM,DIQ,DIR,DIWF,DIWL,DIWR,DLAYGO,DO,DQ,DR,DTOUT,F,G,I,J,N,P,T,X,Y,Z

 +3        KILL BMCPROUT,BMCN,BMCNUM,BMCAGE,BMCFIRST,BMCLAST,BMCLTYP,BMCDTIEN,BMCCPRV,BMCAPPDT,BMCAPUR,BMCDTIEN

 +4        KILL BMCPROV,BMCAPDT,BMCQUIT,BMCCPRV,BMCCPRVP,BMCAPUR,BMCFTYPE,BMCREF,BMCDT,BMCAPPDT,BMCKIND,BMCHOICE,BMCTYPE

 +5        KILL BMCCMT

 +6        QUIT

COMP      ;

 +1        QUIT

WP        ;EP - Entry point to print wp fields pass node in BMCWP

 +1       ;PASS FILE IN BMCFILE, ENTRY IN BMCREF

 +2        NEW G,P,BMCX

 +3        KILL BMCWP

 +4        KILL ^UTILITY($JOB,"W")

 +5        SET BMCX=0

           SET P=0

 +6        SET G=$SELECT($GET(G)]"":G,1:^DIC(BMCFILE,0,"GL"))

           SET G=G_BMCDA_","_BMCNODE_",BMCX)"

 +7        SET DIWR=$SELECT($GET(BMCIOM):BMCIOM,1:IOM)

           SET DIWL=0

FOR

               SET BMCX=$ORDER(@G)

               IF BMCX'=+BMCX

                   QUIT

               Begin DoDot:1

 +8                SET Y=$PIECE(G,")")_",0)"

 +9                SET X=""

                   IF $GET(BMCCAP)]""

                       IF BMCX=1

                           SET X=BMCCAP

 +10               SET X=X_@Y

                   DO ^DIWP

               End DoDot:1

WPS       ;EP

 +1        SET Z=0

FOR

               SET Z=$ORDER(^UTILITY($JOB,"W",DIWL,Z))

               IF Z'=+Z

                   QUIT

               SET P=P+1

               SET BMCWP(P)=^UTILITY($JOB,"W",DIWL,Z,0)

 +2        KILL DIWL,DIWR,DIWF,Z

 +3        KILL ^UTILITY($JOB,"W"),BMCNODE,BMCFILE,BMCDA,G,BMCCOL,BMCCAP

 +4        QUIT

BMCFDR3.m