BMCCLOS1.m

BMCCLOS1 ; IHS/PHXAO/TMJ - CLOSE REFERRALS AUTOMATICALLY ; 

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

POV ;EP

 S BMCFILE=90001 D SETDEF G PROCESS

 ;

SETDEF ;SET DEFAULT OF ACTIVE REFERRALS ONLY

 S BMCCLOS=$O(^BMCREF("AB","A",""))

 Q

XIT ;

 K BMCFILE,BMCDFN,BMCVDG,BMCVIGR,BMCCONT,BMCTEMP,BMCCLOS,BMCG,BMCL,BMCHRN,BMCDOB,BMCVSIT,AUPNSEX,AUPNPAT,AUPNDOB,AUPNDAYS,BMCEIN,AUPNDOD,BMCCAT

 Q

PROCESS ;

 I BMCCLOS="" W !!,"ERROR -- NO ACTIVE REFERRALS ON FILE, NOTIFY YOUR SUPERVISOR" G XIT

 S BMCEIN="",BMCDFN="",U="^"

 I '$D(^DIC(BMCFILE)) W !!,"FILE DOES NOT EXIST -- NOTIFY YOUR SUPERVISOR" G XIT

 S BMCVDG=$P(^DIC(BMCFILE,0),U) I BMCVDG="" W !,"ERROR IN ^DIC -- NOTIFY PROGRAMMER" G XIT

 S BMCVDG=^DIC(BMCFILE,0,"GL")

 ;S BMCG=BMCVDG_"""B"",BMCCLOS)"

 ;S BMCG=BMCVDG_"B"_","_BMCCLOS

 ;I '$D(@BMCG) W ?10,!!,"***There are no .9999 codes to change.***" H 3 Q

 S BMCVIGR=BMCVDG_BMCCLOS_","_0_")"

 W !!,"Searching the ",$P(^DIC(BMCFILE,0),U)," File",!

 S BMCDFN=0,BMCCONT=1 F BMCL=0:0 S BMCDFN=$O(@BMCVIGR) Q:BMCDFN'=+BMCDFN  D CONT Q:'BMCCONT  D BMCDIE

 S BMCDFN=BMCCLOS Q:BMCCLOS'=+BMCDFN  D CONT Q:'BMCCONT  D BMCDIE

 W !!,"All done with the ",$P(^DIC(BMCFILE,0),U)," file",!

 D XIT

 Q

CONT ;

 W !!

 S DIR("A")="Continue",DIR("B")="Y",DIR(0)="Y" D ^DIR

 I $D(DIRUT) S X="N"

 S:"Nn"[X BMCCONT=""

 W !

 K DIR,DIRUT,DUOUT,DTOUT,DIROUT

 Q

BMCDIE ;

 S BMCG=BMCVIGR S Y=$P(@BMCG,U,3),BMCVSIT=$P(@BMCG,U,2) I Y=""!(BMCVSIT="") W !,"ERROR IN GLOBAL -- NOTIFY PROGRAMMER - PATIENT OR VISIT DFN MISSING" Q

 D ^AUPNPAT

 I $L(BMCFILE)>7,AUPNDOB]"" S X2=AUPNDOB,X1=$P(^BMCREF(BMCVSIT,0),U)\1 D ^%DTC S AUPNDAYS=X ; re-set days of age to visit date-dob

 S Y=AUPNDOB X ^DD("DD") S BMCDOB=Y

 S BMCHRN="" I $D(^AUPNPAT(AUPNPAT,41,DUZ(2),0)) S BMCHRN=$P(^AUPNPAT(AUPNPAT,41,DUZ(2),0),U,2)

 W !,"NAME: ",$P(^DPT(AUPNPAT,0),U),"  DOB: ",BMCDOB,"  SEX: ",AUPNSEX,"  HRN: ",$S(BMCHRN]"":BMCHRN,1:"NONE")

 ;I $L(BMCFILE)>7 S BMCCAT=$P(^BMCREF(BMCVSIT,0),U,7) W !,"DATE OF VISIT: " S Y=$P(^AUPNVSIT(BMCVSIT,0),U) D DT^DIO2 S Y=""

 ;

 ;

 ;NOTE TO TONI----DECIDE WHAT REFERRAL INFOR TO DISPLAY

 ;W !!,"HELLO",!!

 ;S BMCRNUM=$$VALI^XBDIQ1(90001,BMCVDG,.02) I $D(BMCRNUM) W !,"REFERRAL NUMBER: ",BMCRNUM

 ;

 ;

 ;S DA=BMCCLOS,DIE=BMCVDG,DR=.27///"C1" D ^DIE K DA,DIE,DR

 ;

 ;I $L(BMCFILE)>7 S AUPNVSIT=BMCVSIT D MOD^AUPNVSIT

 S DA=BMCVSIT,DIE="^BMCREF(",DR=".27////"_DT D ^DIE K DA,DIE,DIU,DIV,DR

 ;Stuff Todays's Date in field .27 Date Last Modified in BMCREF(

 ;

 S DA=BMCCLOS,DIE="^BMCREF(",DR=".15///"_"C1" D ^DIE K DA,DIE,DIU,DIV,DR

 ;

 Q

BMCCLOS1  ; IHS/PHXAO/TMJ - CLOSE REFERRALS AUTOMATICALLY ; 

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

POV       ;EP

 +1        SET BMCFILE=90001

           DO SETDEF

           GOTO PROCESS

 +2       ;

SETDEF    ;SET DEFAULT OF ACTIVE REFERRALS ONLY

 +1        SET BMCCLOS=$ORDER(^BMCREF("AB","A",""))

 +2        QUIT 

XIT       ;

 +1        KILL BMCFILE,BMCDFN,BMCVDG,BMCVIGR,BMCCONT,BMCTEMP,BMCCLOS,BMCG,BMCL,BMCHRN,BMCDOB,BMCVSIT,AUPNSEX,AUPNPAT,AUPNDOB,AUPNDAYS,BMCEIN,AUPNDOD,BMCCAT

 +2        QUIT 

PROCESS   ;

 +1        IF BMCCLOS=""

               WRITE !!,"ERROR -- NO ACTIVE REFERRALS ON FILE, NOTIFY YOUR SUPERVISOR"

               GOTO XIT

 +2        SET BMCEIN=""

           SET BMCDFN=""

           SET U="^"

 +3        IF '$DATA(^DIC(BMCFILE))

               WRITE !!,"FILE DOES NOT EXIST -- NOTIFY YOUR SUPERVISOR"

               GOTO XIT

 +4        SET BMCVDG=$PIECE(^DIC(BMCFILE,0),U)

           IF BMCVDG=""

               WRITE !,"ERROR IN ^DIC -- NOTIFY PROGRAMMER"

               GOTO XIT

 +5        SET BMCVDG=^DIC(BMCFILE,0,"GL")

 +6       ;S BMCG=BMCVDG_"""B"",BMCCLOS)"

 +7       ;S BMCG=BMCVDG_"B"_","_BMCCLOS

 +8       ;I '$D(@BMCG) W ?10,!!,"***There are no .9999 codes to change.***" H 3 Q

 +9        SET BMCVIGR=BMCVDG_BMCCLOS_","_0_")"

 +10       WRITE !!,"Searching the ",$PIECE(^DIC(BMCFILE,0),U)," File",!

 +11       SET BMCDFN=0

           SET BMCCONT=1

           FOR BMCL=0:0

               SET BMCDFN=$ORDER(@BMCVIGR)

               IF BMCDFN'=+BMCDFN

                   QUIT 

               DO CONT

               IF 'BMCCONT

                   QUIT 

               DO BMCDIE

 +12       SET BMCDFN=BMCCLOS

           IF BMCCLOS'=+BMCDFN

               QUIT 

           DO CONT

           IF 'BMCCONT

               QUIT 

           DO BMCDIE

 +13       WRITE !!,"All done with the ",$PIECE(^DIC(BMCFILE,0),U)," file",!

 +14       DO XIT

 +15       QUIT 

CONT      ;

 +1        WRITE !!

 +2        SET DIR("A")="Continue"

           SET DIR("B")="Y"

           SET DIR(0)="Y"

           DO ^DIR

 +3        IF $DATA(DIRUT)

               SET X="N"

 +4        IF "Nn"[X

               SET BMCCONT=""

 +5        WRITE !

 +6        KILL DIR,DIRUT,DUOUT,DTOUT,DIROUT

 +7        QUIT 

BMCDIE    ;

 +1        SET BMCG=BMCVIGR

           SET Y=$PIECE(@BMCG,U,3)

           SET BMCVSIT=$PIECE(@BMCG,U,2)

           IF Y=""!(BMCVSIT="")

               WRITE !,"ERROR IN GLOBAL -- NOTIFY PROGRAMMER - PATIENT OR VISIT DFN MISSING"

               QUIT 

 +2        DO ^AUPNPAT

 +3       ; re-set days of age to visit date-dob

           IF $LENGTH(BMCFILE)>7

               IF AUPNDOB]""

                   SET X2=AUPNDOB

                   SET X1=$PIECE(^BMCREF(BMCVSIT,0),U)\1

                   DO ^%DTC

                   SET AUPNDAYS=X

 +4        SET Y=AUPNDOB

           XECUTE ^DD("DD")

           SET BMCDOB=Y

 +5        SET BMCHRN=""

           IF $DATA(^AUPNPAT(AUPNPAT,41,DUZ(2),0))

               SET BMCHRN=$PIECE(^AUPNPAT(AUPNPAT,41,DUZ(2),0),U,2)

 +6        WRITE !,"NAME: ",$PIECE(^DPT(AUPNPAT,0),U),"  DOB: ",BMCDOB,"  SEX: ",AUPNSEX,"  HRN: ",$SELECT(BMCHRN]"":BMCHRN,1:"NONE")

 +7       ;I $L(BMCFILE)>7 S BMCCAT=$P(^BMCREF(BMCVSIT,0),U,7) W !,"DATE OF VISIT: " S Y=$P(^AUPNVSIT(BMCVSIT,0),U) D DT^DIO2 S Y=""

 +8       ;

 +9       ;

 +10      ;NOTE TO TONI----DECIDE WHAT REFERRAL INFOR TO DISPLAY

 +11      ;W !!,"HELLO",!!

 +12      ;S BMCRNUM=$$VALI^XBDIQ1(90001,BMCVDG,.02) I $D(BMCRNUM) W !,"REFERRAL NUMBER: ",BMCRNUM

 +13      ;

 +14      ;

 +15      ;S DA=BMCCLOS,DIE=BMCVDG,DR=.27///"C1" D ^DIE K DA,DIE,DR

 +16      ;

 +17      ;I $L(BMCFILE)>7 S AUPNVSIT=BMCVSIT D MOD^AUPNVSIT

 +18       SET DA=BMCVSIT

           SET DIE="^BMCREF("

           SET DR=".27////"_DT

           DO ^DIE

           KILL DA,DIE,DIU,DIV,DR

 +19      ;Stuff Todays's Date in field .27 Date Last Modified in BMCREF(

 +20      ;

 +21       SET DA=BMCCLOS

           SET DIE="^BMCREF("

           SET DR=".15///"_"C1"

           DO ^DIE

           KILL DA,DIE,DIU,DIV,DR

 +22      ;

 +23       QUIT