BMCCLO ; IHS/PHXAO/TMJ - CLOSE OUT A REFERRAL ; [ 09/27/2006 1:32 PM ]
;;4.0;REFERRED CARE INFO SYSTEM;**1,2,8,9**;JAN 09, 2006;Build 101
;
; This option allows the RCIS manager to select and close out
; referrals.
;BMC*4.0*8;IHS/OIT/FCJ; ADDED SNOMED PROMPT AND TEST FOR TOC PENDING
;
;
START ;
S BMCCLOSE=1
F D MAIN Q:BMCQ D HDR^BMC
D EOJ
Q
;
MAIN ;
S BMCQ=0
D REFERRAL ; get referral record to close out
Q:BMCQ
D GETSNO^BMCADD3 ;bmc*4.0*8 Set snomed code
D FINAL ; get final values
D STATUS ; get final status
Q:BMCQ
D VERIFY ; make sure all required fields present
Q:BMCQ
D CLOSE ; close out referral
D PCCL
Q
;
REFERRAL ; GET REFERRAL TO CLOSE
;S BMCQ=1 ;BMC*4.0*8
W !
;S DIC="^BMCREF(",DIC(0)="AEMQ",DIC("S")="I $$FILTER^BMCFLTR(2,BMCCURFY,0)",DIC("A")="Select RCIS REFERRAL by Patient or by Referral Date or #: "
S DIC="^BMCREF(",DIC(0)="AEMQ",DIC("S")="I $$FILTER^BMCFLTR(2,BMCCURFY,2)",DIC("A")="Select RCIS REFERRAL by Patient or by Referral Date or #: "
D DIC^BMCFMC
;Q:Y<1 ;BMC*4.0*8
I Y<1 S BMCQ=1 Q ;BMC*4.0*8
S BMCRIEN=+Y
;BMC*4.0*8 NEW TEST FOR TOC
I $P($G(^BMCREF(BMCRIEN,13)),U,3),$P(^BMCREF(BMCRIEN,0),U,15)="A1",$P(^BMCREF(BMCRIEN,13),U,4)="P" D Q:BMCQ
.W !,"The Transfer of Care Document has not been printed, faxed or transmitted."
.W !,"Please complete this before closing the Referral.",!
.S DIR(0)="YO",DIR("A")="Do you want to quit the close process",DIR("B")="Y" K DA D ^DIR K DIR
.S:($D(DIRUT))!(Y) BMCQ=1
;BMC*4.0*8 END OF CHANGES
S BMCQ=0
Q
;
FINAL ; GET FINAL VALUES
S DIR(0)="YO",DIR("A")="Do you want to enter final values",DIR("B")="Y" K DA D ^DIR K DIR
Q:$D(DIRUT)
Q:'Y
S (BMCDXT,BMCPXT)="F"
S BMCMODE="M" ;BMC*4.0*1 IHS/OIT/FCJ 1.19.06
S BMCDOS=$$AVDOS^BMCRLU(BMCRIEN,"N") ;BMC*4.0*9
F D TYPE^BMCMOD Q:BMCQ ; modify referral
S BMCQ=0
Q
;
STATUS ; GET FINAL STATUS
W !!
F D STATUS2 Q:BMCQ!(BMCSTAT]"")
Q
;
STATUS2 ;
;BMC 4.0*2 8/17/06 IHS/OIT/FCJ REMOVED "A" AS AN OPTION NXT SECTION
S BMCSTAT=""
;S DIR(0)="90001,.15",DIR("A")="Enter Final Status",DIR("B")="C1" K DA D ^DIR K DIR
S DIR(0)="S^C1:CLOSED COMPLETED;X:CLOSED NOT COMPLETED"
S DIR("A")="Enter Final Status",DIR("B")="C1" K DA D ^DIR K DIR
I $D(DIRUT) S BMCQ=1 Q
S BMCSTAT=Y
;I BMCSTAT="A" S BMCSTAT="" W " Final status cannot be 'ACTIVE'",!,*7 Q
Q
;
VERIFY ; MAKE SURE ALL REQUIRED FIELDS ARE PRESENT
Q:BMCSTAT'="C1"
F D VERIFY2 Q:BMCLQ
Q
;
VERIFY2 ;
S BMCLQ=0
D VERIFY3
Q:BMCLQ
W !,*7
S DIR(0)="Y",DIR("A")="Required fields missing. Do you want to enter them",DIR("B")="Y" K DA D ^DIR K DIR
I 'Y S (BMCLQ,BMCQ)=1 Q
S DIE="^BMCREF(",DA=BMCRIEN
D DIE^BMCFMC
Q
;
VERIFY3 ;
S DR=""
I BMCRTYPE="C" S X=.07 D VERIFYRQ
I BMCRTYPE="I" S X=.08 D VERIFYRQ
; should require either .07 or .09 if type='o'
F X=1102,1104,1106,1108 D VERIFYRQ
I BMCRIO="I" S X=1110 D VERIFYRQ
S:$E(DR)=";" $E(DR)=""
I DR="" S BMCLQ=1 K DR Q
SNOCLS ;EP FR BMCCHS;BMC*4.0*8 7.22.13 IHS.OIT.FCJ; ADD SNOMED CODE WHEN CLOSED-COMPLETED AND ACTUAL DOS
Q:$D(^BMCREF(BMCRIEN,23,"B",371531000))
S DIC="^BMCREF(",X=371531000
S DIADD=1,DIC(0)="L",LAYGO=90001 S:'$D(^BMCREF(BMCRIEN,23)) DIC("P")=90001.23
S DIC=DIC_BMCRIEN_",23,",DA(1)=BMCRIEN
D ^DIC
I +Y<0 W !,"The closure snomed clinical term was not added to the referral."
Q
;
VERIFYRQ ; CHK REQUIRED FIELDS
I $$VALI^XBDIQ1(90001,BMCRIEN,X)="" S DR=DR_";"_X
Q
;
CLOSE ; CLOSE REFERRAL RECORD
S DIE="^BMCREF(",DR="[BMC REFERRAL STATUS]",DA=BMCRIEN
D DIE^BMCFMC
Q
;
PCCL ; PCC LINK
I $$VALI^XBDIQ1(90001,BMCRIEN,".15")="C1" D ^BMCPCCL
Q
;
EOJ ; END OF JOB
K BMCMODE D ^BMCKILL ;BMC*4.0*1 IHS/OIT/FCJ 1.19.06
;D ^BMCKILL
Q
BMCCLO ; IHS/PHXAO/TMJ - CLOSE OUT A REFERRAL ; [ 09/27/2006 1:32 PM ]
+1 ;;4.0;REFERRED CARE INFO SYSTEM;**1,2,8,9**;JAN 09, 2006;Build 101
+2 ;
+3 ; This option allows the RCIS manager to select and close out
+4 ; referrals.
+5 ;BMC*4.0*8;IHS/OIT/FCJ; ADDED SNOMED PROMPT AND TEST FOR TOC PENDING
+6 ;
+7 ;
START ;
+1 SET BMCCLOSE=1
+2 FOR
DO MAIN
IF BMCQ
QUIT
DO HDR^BMC
+3 DO EOJ
+4 QUIT
+5 ;
MAIN ;
+1 SET BMCQ=0
+2 ; get referral record to close out
DO REFERRAL
+3 IF BMCQ
QUIT
+4 ;bmc*4.0*8 Set snomed code
DO GETSNO^BMCADD3
+5 ; get final values
DO FINAL
+6 ; get final status
DO STATUS
+7 IF BMCQ
QUIT
+8 ; make sure all required fields present
DO VERIFY
+9 IF BMCQ
QUIT
+10 ; close out referral
DO CLOSE
+11 DO PCCL
+12 QUIT
+13 ;
REFERRAL ; GET REFERRAL TO CLOSE
+1 ;S BMCQ=1 ;BMC*4.0*8
+2 WRITE !
+3 ;S DIC="^BMCREF(",DIC(0)="AEMQ",DIC("S")="I $$FILTER^BMCFLTR(2,BMCCURFY,0)",DIC("A")="Select RCIS REFERRAL by Patient or by Referral Date or #: "
+4 SET DIC="^BMCREF("
SET DIC(0)="AEMQ"
SET DIC("S")="I $$FILTER^BMCFLTR(2,BMCCURFY,2)"
SET DIC("A")="Select RCIS REFERRAL by Patient or by Referral Date or #: "
+5 DO DIC^BMCFMC
+6 ;Q:Y<1 ;BMC*4.0*8
+7 ;BMC*4.0*8
IF Y<1
SET BMCQ=1
QUIT
+8 SET BMCRIEN=+Y
+9 ;BMC*4.0*8 NEW TEST FOR TOC
+10 IF $PIECE($GET(^BMCREF(BMCRIEN,13)),U,3)
IF $PIECE(^BMCREF(BMCRIEN,0),U,15)="A1"
IF $PIECE(^BMCREF(BMCRIEN,13),U,4)="P"
Begin DoDot:1
+11 WRITE !,"The Transfer of Care Document has not been printed, faxed or transmitted."
+12 WRITE !,"Please complete this before closing the Referral.",!
+13 SET DIR(0)="YO"
SET DIR("A")="Do you want to quit the close process"
SET DIR("B")="Y"
KILL DA
DO ^DIR
KILL DIR
+14 IF ($DATA(DIRUT))!(Y)
SET BMCQ=1
End DoDot:1
IF BMCQ
QUIT
+15 ;BMC*4.0*8 END OF CHANGES
+16 SET BMCQ=0
+17 QUIT
+18 ;
FINAL ; GET FINAL VALUES
+1 SET DIR(0)="YO"
SET DIR("A")="Do you want to enter final values"
SET DIR("B")="Y"
KILL DA
DO ^DIR
KILL DIR
+2 IF $DATA(DIRUT)
QUIT
+3 IF 'Y
QUIT
+4 SET (BMCDXT,BMCPXT)="F"
+5 ;BMC*4.0*1 IHS/OIT/FCJ 1.19.06
SET BMCMODE="M"
+6 ;BMC*4.0*9
SET BMCDOS=$$AVDOS^BMCRLU(BMCRIEN,"N")
+7 ; modify referral
FOR
DO TYPE^BMCMOD
IF BMCQ
QUIT
+8 SET BMCQ=0
+9 QUIT
+10 ;
STATUS ; GET FINAL STATUS
+1 WRITE !!
+2 FOR
DO STATUS2
IF BMCQ!(BMCSTAT]"")
QUIT
+3 QUIT
+4 ;
STATUS2 ;
+1 ;BMC 4.0*2 8/17/06 IHS/OIT/FCJ REMOVED "A" AS AN OPTION NXT SECTION
+2 SET BMCSTAT=""
+3 ;S DIR(0)="90001,.15",DIR("A")="Enter Final Status",DIR("B")="C1" K DA D ^DIR K DIR
+4 SET DIR(0)="S^C1:CLOSED COMPLETED;X:CLOSED NOT COMPLETED"
+5 SET DIR("A")="Enter Final Status"
SET DIR("B")="C1"
KILL DA
DO ^DIR
KILL DIR
+6 IF $DATA(DIRUT)
SET BMCQ=1
QUIT
+7 SET BMCSTAT=Y
+8 ;I BMCSTAT="A" S BMCSTAT="" W " Final status cannot be 'ACTIVE'",!,*7 Q
+9 QUIT
+10 ;
VERIFY ; MAKE SURE ALL REQUIRED FIELDS ARE PRESENT
+1 IF BMCSTAT'="C1"
QUIT
+2 FOR
DO VERIFY2
IF BMCLQ
QUIT
+3 QUIT
+4 ;
VERIFY2 ;
+1 SET BMCLQ=0
+2 DO VERIFY3
+3 IF BMCLQ
QUIT
+4 WRITE !,*7
+5 SET DIR(0)="Y"
SET DIR("A")="Required fields missing. Do you want to enter them"
SET DIR("B")="Y"
KILL DA
DO ^DIR
KILL DIR
+6 IF 'Y
SET (BMCLQ,BMCQ)=1
QUIT
+7 SET DIE="^BMCREF("
SET DA=BMCRIEN
+8 DO DIE^BMCFMC
+9 QUIT
+10 ;
VERIFY3 ;
+1 SET DR=""
+2 IF BMCRTYPE="C"
SET X=.07
DO VERIFYRQ
+3 IF BMCRTYPE="I"
SET X=.08
DO VERIFYRQ
+4 ; should require either .07 or .09 if type='o'
+5 FOR X=1102,1104,1106,1108
DO VERIFYRQ
+6 IF BMCRIO="I"
SET X=1110
DO VERIFYRQ
+7 IF $EXTRACT(DR)=";"
SET $EXTRACT(DR)=""
+8 IF DR=""
SET BMCLQ=1
KILL DR
QUIT
SNOCLS ;EP FR BMCCHS;BMC*4.0*8 7.22.13 IHS.OIT.FCJ; ADD SNOMED CODE WHEN CLOSED-COMPLETED AND ACTUAL DOS
+1 IF $DATA(^BMCREF(BMCRIEN,23,"B",371531000))
QUIT
+2 SET DIC="^BMCREF("
SET X=371531000
+3 SET DIADD=1
SET DIC(0)="L"
SET LAYGO=90001
IF '$DATA(^BMCREF(BMCRIEN,23))
SET DIC("P")=90001.23
+4 SET DIC=DIC_BMCRIEN_",23,"
SET DA(1)=BMCRIEN
+5 DO ^DIC
+6 IF +Y<0
WRITE !,"The closure snomed clinical term was not added to the referral."
+7 QUIT
+8 ;
VERIFYRQ ; CHK REQUIRED FIELDS
+1 IF $$VALI^XBDIQ1(90001,BMCRIEN,X)=""
SET DR=DR_";"_X
+2 QUIT
+3 ;
CLOSE ; CLOSE REFERRAL RECORD
+1 SET DIE="^BMCREF("
SET DR="[BMC REFERRAL STATUS]"
SET DA=BMCRIEN
+2 DO DIE^BMCFMC
+3 QUIT
+4 ;
PCCL ; PCC LINK
+1 IF $$VALI^XBDIQ1(90001,BMCRIEN,".15")="C1"
DO ^BMCPCCL
+2 QUIT
+3 ;
EOJ ; END OF JOB
+1 ;BMC*4.0*1 IHS/OIT/FCJ 1.19.06
KILL BMCMODE
DO ^BMCKILL
+2 ;D ^BMCKILL
+3 QUIT
