- 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
