- 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
