Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BMCFDRA

BMCFDRA.m

Go to the documentation of this file.
  1. BMCFDRA ; IHS/PHXAO/TMJ - DRIVER TO PRINT ALT RESOURCE LETTER ;
  1. ;;4.0;REFERRED CARE INFO SYSTEM;**4**;JAN 09, 2006;Build 101
  1. START ;
  1. W:$D(IOF) @IOF
  1. W "********** REFERRAL FORM PRINT **********",!!
  1. W "This report will produce a hard copy computer generated Alternate Resource",!,"Application Letter",!
  1. S BMCQUIT=0
  1. GETTYPE ;Select Alternate Resource Contact & set Text Verbiage
  1. S BMCFTYPE=3
  1. S DIC="^BMCALT(",DIC(0)="AEMQ",DIC("A")="Select Letter Contact Point: " D ^DIC K DA,DIC
  1. G:Y=-1 XIT
  1. S BMCCPRV=+Y
  1. S BMCCPRVP=$P($G(^BMCALT(BMCCPRV,0)),U)
  1. GETREF ;get referral entry
  1. W !! S BMCREF=""
  1. S DIC="^BMCREF(",DIC(0)="AEMQ",DIC("A")="Select Referral by Patient Name, date of referral or referral #: " D ^DIC K DA,DIC
  1. G:Y=-1 XIT
  1. S BMCREF=+Y
  1. I $D(^BMCTFORM(BMCFTYPE,11)) X ^BMCTFORM(BMCFTYPE,11) G:BMCQUIT GETREF
  1. ;
  1. ;Alt Resource Documentation Information
  1. S DA=BMCREF,DIE="^BMCREF(",DR="1501Enter Appointment Documentation" D ^DIE K DA,DIE,DIU,DIVDR
  1. ;
  1. TYPE ;Get Type of Letter Dissemination
  1. S BMCLTYP=""
  1. S DA=BMCREF,DIE="^BMCREF(",DR="1404Select Type of Distribution" D ^DIE K DA,DIE,DIU,DIVDR
  1. ;
  1. S BMCLTYP=X
  1. I BMCLTYP'="M" G ZIS
  1. ;
  1. ;Alt Resource Mail Certified Receipt Number
  1. S DA=BMCREF,DIE="^BMCREF(",DR="1403Enter Certified Mail Receipt" D ^DIE K DA,DIE,DIU,DIVDR
  1. ;
  1. ZIS ;
  1. W !! S XBRC="COMP^BMCFDRA",XBRP="PRINT^BMCFDRA",XBNS="BMC",XBRX="XIT^BMCFDRA"
  1. D ^XBDBQUE
  1. Q
  1. ;
  1. PRINT ;EP
  1. X:$D(^BMCTFORM(BMCFTYPE,12)) ^BMCTFORM(BMCFTYPE,12)
  1. Q
  1. XIT ;
  1. ;BMC*4.0*4 IHS/OIT/FCJ ADDED BMCSIR
  1. K BMCCAP,BMCCHSR,BMCDA,BMCFILE,BMCFTYPE,BMCIOM,BMCKPDA,BMCNODE,BMCPG,BMCQUIT,BMCR0,BMCREF,BMCRNS,BMCV,BMCWP,BMCX,BMCY,BMCI,BMCDFN,BMCCHSAS
  1. 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
  1. K BMCPROUT,BMCN,BMCNUM,BMCAGE,BMCFIRST,BMCLAST,BMCLTYP,BMCSIR
  1. Q
  1. COMP ;
  1. Q
  1. WP ;EP - Entry point to print wp fields pass node in BMCWP
  1. ;PASS FILE IN BMCFILE, ENTRY IN BMCREF
  1. NEW G,P,BMCX
  1. K BMCWP
  1. K ^UTILITY($J,"W")
  1. S BMCX=0,P=0
  1. S G=$S($G(G)]"":G,1:^DIC(BMCFILE,0,"GL")),G=G_BMCDA_","_BMCNODE_",BMCX)"
  1. S DIWR=$S($G(BMCIOM):BMCIOM,1:IOM),DIWL=0 F S BMCX=$O(@G) Q:BMCX'=+BMCX D
  1. .S Y=$P(G,")")_",0)"
  1. .S X="" I $G(BMCCAP)]"",BMCX=1 S X=BMCCAP
  1. .S X=X_@Y D ^DIWP
  1. .Q
  1. WPS ;EP
  1. 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)
  1. K DIWL,DIWR,DIWF,Z
  1. K ^UTILITY($J,"W"),BMCNODE,BMCFILE,BMCDA,G,BMCCOL,BMCCAP
  1. Q
  1. CHSSTAT ;EP
  1. Q:BMCFTYPE'=1
  1. Q ;Quit - No longer ask for CHS Preliminary Review per Stan 8/28/96
  1. Q:$P(^BMCREF(BMCREF,0),U,4)'="C"
  1. I $P($G(^BMCREF(BMCREF,11)),U,20)]"" S BMCCHSR=$P(^BMCREF(BMCREF,11),U,20) Q
  1. W !!,$C(7),$C(7),"The CHS Preliminary Review has not been entered. Please enter it now.",!
  1. S DIE="^BMCREF(",DA=BMCREF,DR=1120 D ^DIE K DIE,DA
  1. S BMCCHSR=$P($G(^BMCREF(BMCREF,11)),U,20) I BMCCHSR="" S BMCCHSR="3" W !!,"No entry made. Defaulting to 'TO BE DETERMINED'.",!!
  1. Q
  1. AHCCCS ;EP
  1. W !!,$C(7),$C(7),"This letter must be printed on a printer capable of 132 character print.",!!
  1. Q