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

BSDAPP.m

Go to the documentation of this file. 
  1. BSDAPP ; IHS/ANMC/LJF - IHS CALLS FROM SDAPP ;  [ 08/20/2004  11:51 AM ]
  1.  ;;5.3;PIMS;**1001,1003,1004,1009**;MAY 28, 2004
  1.  ;IHS/ITSC/LJF 06/15/2005 PATCH 1003 add ability to print future chart requests now
  1.  ;IHS/OIT/LJF  07/28/2005 PATCH 1004 don't ask for printer if future date and printing in future
  1.  ;cmi/anch/maw 02/21/2008 PATCH 1009 mods to print requirement 36
  1.  ;cmi/anch/maw 02/21/2008 PATCH 1009 mods to print requirement 35
  1.  ;
  1. CR ;EP;Chart Request entry; called by SDAPP
  1.  ; rewrote VA code to make it less confusing
  1.  ;
  1.  NEW DIC,DIE,DA,DR,BSDV,BSDC,BSDCNT,BSDQ,DFN,BSDDT,X,Y,DLAYGO
  1.  S (DIC,DIE)="^SC(",DIC(0)="AQME",DIC("A")="SELECT CLINIC NAME: "
  1.  S DIC("W")=$$INACTMSG^BSDU
  1.  ; screen: must be clinic, not out-of-service and have division set
  1.  S DIC("S")="I $P(^(0),U,3)=""C"",'$G(^(""OOS"")),$P(^(0),U,15)]"""""
  1.  D ^DIC K DIC("A"),DIC("S") Q:+Y<0  S BSDC=+Y
  1.  ;
  1.  ; check out inactive status
  1.  S SDIN=$S($D(^SC(BSDC,"I")):1,1:""),SDRE=""
  1.  I SDIN S SDIN=+^SC(BSDC,"I"),SDRE=+$P(^("I"),"^",2)
  1.  I SDIN,SDIN'>DT,'SDRE S D0=+Y D WRT1^SDAPP Q
  1.  ;
  1.  S BSDV=$$DELIVER Q:BSDV=""     ;ask delivery info
  1.  ;
  1.  ; ask for date and stuff into clinic if not there yet
  1.  S BSDDT=$$READ^BDGF("DOA^"_DT_"::EX","Select Chart Delivery Date: ")
  1.  Q:'BSDDT
  1.  I '$D(^SC(BSDC,"C",BSDDT)) K DIC,DA D    ;add date for clinic
  1.  . S DIC="^SC("_BSDC_",""C"",",DA(1)=BSDC,DIC(0)="L",DLAYGO=44.006
  1.  . S DIC("P")=$P(^DD(44,1906,0),U,2)
  1.  . S X=BSDDT D ^DIC
  1.  I '$D(^SC(BSDC,"C",BSDDT)) W !!,"Problem with this date for this clinic. Notify computer department." Q
  1.  ;
  1.  ;IHS/ITSC/LJF 06/15/2005 PATCH 1003
  1.  NEW BSDNOW K ^TMP("BSDNOW",$J)
  1.  S BSDNOW=$$GET1^DIQ(9009020.2,$$DIV^BSDU,.14) I BSDNOW="" S BSDNOW="FUTURE"
  1.  ;end of PATCH 1003 changes
  1.  ;
  1.  ; ask for patients and check against previous appt and chart requests
  1.  S (BSDQ,BSDCNT)=0 F  Q:BSDQ=1  D
  1.  . S DFN=+$$READ^BDGF("PO^2:EMQZ","Select PATIENT") I DFN<1 S BSDQ=1 Q
  1.  . Q:'$$OKAY(DFN,BSDDT)    ;show info to user and ask if okay
  1.  . K DIC,DIE,DA,DR
  1.  . S DIC="^SC("_BSDC_",""C"","_BSDDT_",1,",DIC(0)="L",DLAYGO=44.007
  1.  . S DIC("P")=$P(^DD(44.006,2,0),U,2)
  1.  . S DA(2)=BSDC,DA(1)=BSDDT,X=DFN
  1.  . D FILE^DICN
  1.  . I Y<1 W !!,"Problem recording chart request for patient.  Contact computer department." Q
  1.  . ;
  1.  . I BSDNOW="NOW" S ^TMP("BSDNOW",$J,+Y)=""   ;IHS/ITSC/LJF 06/15/2005 PATCH 1003
  1.  . ;
  1.  . S DIE=DIC,DA=+Y
  1.  . S DR="9999999.01///^S X=$$NOW^XLFDT;9999999.02///^S X=""`""_DUZ;9999999.03///"_BSDV
  1.  . D ^DIE
  1.  . I '$G(Y) W !?5,"chart request recorded...",!!
  1.  . S BSDCNT=BSDCNT+1    ;increment count
  1.  ;
  1.  I BSDNOW="FUTURE",BSDDT'=DT Q   ;quit if future date and want to print in the future ;IHS/OIT/LJF 7/28/2005 PATCH 1004
  1.  ; if at least one CR recorded, ask for printer
  1.  ;I BSDCNT>0 W ! D PRINT(BSDC)
  1.  I BSDCNT>0 W ! D PRINT(BSDC,0,BSDDT,BSDNOW)   ;IHS/ITSC/LJF 06/15/2005 PATCH 1003
  1.  Q
  1.  ;
  1.  ;
  1. OKAY(PAT,DATE) ; find other appts and chart requests for date
  1.  ; if any found, ask user if they still want to request chart
  1.  NEW CLN,IEN,FIRST
  1.  S FIRST=1
  1.  ;
  1.  ; show if current inpatient
  1.  I $G(^DPT(PAT,.1))]"" D
  1.  . W !!,"** Current "
  1.  . NEW X S X=$$GET1^DIQ(2,PAT,.103)
  1.  . W $S(X["OBSERVATION":"Observation Patient",1:"Inpatient")
  1.  . W " on "_$G(^DPT(PAT,.1))_" ward **"
  1.  . S FIRST=0
  1.  ;
  1.  ; check for any chart requests
  1.  S CLN=0
  1.  F  S CLN=$O(^SC("AIHSCR",PAT,CLN)) Q:'CLN  D
  1.  . S IEN=0 F  S IEN=$O(^SC("AIHSCR",PAT,CLN,DATE,IEN)) Q:'IEN  D
  1.  .. I FIRST W !!,"Patient's chart already requested for:" S FIRST=0
  1.  .. W !?3,"Chart Request for ",$$GET1^DIQ(44,CLN,.01),?40,"made at "
  1.  .. W $$GET1^DIQ(44.007,IEN_","_DATE_","_CLN,9999999.01)
  1.  ;
  1.  ; now check for any appointments
  1.  S IEN=DATE
  1.  F  S IEN=$O(^DPT(PAT,"S",IEN)) Q:'IEN  Q:(IEN>(DATE+.24))  D
  1.  . I FIRST W !!,"Patient's chart already requested for:" S FIRST=0
  1.  . W !?3,"APPT at ",$$TIME^BDGF(IEN),?25,"for "
  1.  . W $$GET1^DIQ(44,+^DPT(PAT,"S",IEN,0),.01)
  1.  ;
  1.  I FIRST Q 1   ;if nothing found, okay to proceed
  1.  ;
  1.  Q +$$READ^BDGF("YO","Do you still want to request this chart","NO")
  1.  ;
  1. DELIVER() ; -- asks user for delivery info
  1.  NEW X,Y,DIR,DIRUT
  1.  ;IHS/ITSC/WAR 5/20/04 P #1001 Change in verbage
  1.  ;S DIR(0)="F^3:60",DIR("A")="DELIVER CHARTS TO (PROVIDER/LOCATION/EXT.)"
  1.  S DIR(0)="F^3:60",DIR("A")="REQUEST CHARTS FOR (PROVIDER/LOCATION/EXT.)"
  1.  D ^DIR I $D(DIRUT) S Y=""
  1.  I Y[";" S X(";")="-",Y=$$REPLACE^XLFSTR(Y,.X)
  1.  Q Y
  1.  ;
  1.  ;IHS/ITSC/LJF 06/15/2005 PATCH 1003 added 2 new parameters
  1. PRINT(CLN,ADMIT,BSDDT,BSDNOW) ; set up print job for routing slips
  1.  ; called by this routine after recording chart requests
  1.  ; called by admission chart request ADMIT^BSDAPP
  1.  ; CLN=chart request clinic
  1.  ; ADMIT (optional), if set to 1, don't use default printer
  1.  ;
  1.  ;IHS/ITSC/LJF 06/15/2005 PATCH 1003
  1.  ; BSDDT (optional), if set contains chart request date
  1.  ; BSDNOW = NOW or FUTURE
  1.  ;Q:'$D(^SC(CLN,"C",DT))    ;none for today; wait for add-ons
  1.  I $G(BSDNOW)'="NOW" Q:'$D(^SC(CLN,"C",DT))
  1.  ;end of these PATCH 1003 changes
  1.  ;
  1.  NEW VAUTC,SDATE,ORDER,SDX,SDREP,IEN,SDPARMS,DEV,DFN
  1.  S VAUTC=0,VAUTC(CLN)=$$GET1^DIQ(44,CLN,.01)
  1.  S SDATE=DT,ORDER=4,SDX="ALL",SDREP=""
  1.  ;
  1.  S SDATE=$S($G(BSDDT):BSDDT,1:DT)  ;IHS/ITSC/LJF 061/5/2005 PATCH 1003
  1.  ;
  1.  S SDPARMS("DO NOT CLOSE")=1
  1.  ;
  1.  ; ask for print device, pull default from parameters
  1.  ;IHS/ITSC/LJF 06/15/2005 PATCH 1003 use choice of default printers
  1.  ;S DEV=$S($G(ADMIT)=1:"",1:$$GET1^DIQ(9009020.2,$$DIV^BSDU,.05))
  1.  S DEV=$S($G(ADMIT)=1:"",1:$$GET1^DIQ(9009020.2,$$DIV^BSDU,$S($G(BSDDT)=DT:.05,1:.21)))
  1.  ;
  1.  I $D(DGQUIET),DEV="" Q
  1.  S %ZIS="N",%ZIS("A")="Chart Request Printer: "
  1.  ;S:DEV]"" %ZIS("B")=DEV D ^%ZIS Q:POP  ;cmi/maw 2/21/2008 PATCH 1009 requirement 35 orig line
  1. DEVP S:DEV]"" %ZIS("B")=DEV D ^%ZIS
  1.  I POP W !,"Exiting out prevents, the remaining chart requests from printing, please select a device" G DEVP  ;cmi/maw 2/21/2008 PATCH 1009 requirement 35
  1.  ;cmi/maw 2/21/2008 PATCH 1009 requirement 36
  1.  I $G(IOS),$P($G(^%ZIS(1,IOS,0)),U,12)=2 D  Q
  1.  . Q:$D(DGQUIET)
  1.  . W !,"You must select a device that allows queueing"
  1.  . H 2
  1.  ;cmi/maw 2/21/2008 PATCH 1009 end of mods requirement 36
  1.  ;
  1.  ; find each patient and make separate call
  1.  NEW BDGQT I $D(DGQUIET) S BDGQT=1   ;was DGQUIET already set?
  1.  S DGQUIET=1,BSDDEV=ION
  1.  S IEN=0 F  S IEN=$O(^SC(CLN,"C",SDATE,1,IEN)) Q:'IEN  D
  1.  . Q:$P($G(^SC(CLN,"C",SDATE,1,IEN,9999999)),U,4)]""  ;already printed
  1.  . ;
  1.  . ;IHS/ITSC/LJF 06/15/2005 PATCH 1003
  1.  . ; if printing future CRs now, was this one of your patient's
  1.  . I $G(BSDNOW)="NOW" Q:'$D(^TMP("BSDNOW",$J,IEN))
  1.  . ;
  1.  . S DFN=+$G(^SC(CLN,"C",SDATE,1,IEN,0)) Q:'DFN
  1.  . D WISD^BSDROUT(DFN,SDATE,"CR",BSDDEV)
  1.  D ^%ZISC
  1.  K BSDDEV
  1.  I '$D(BDGQT) K DGQUIET   ;only kill if not set in previous call
  1.  K ^TMP("BSDNOW",$J)    ;IHS/ITSC/LJF 06/15/2005 PATCH 1003
  1.  Q
  1.  ;
  1. ADMIT(DFN,DGQUIET,BSDCLN,BSDDELV,BSDADT) ;EP; request chart at admission
  1.  ; Called by ADT Event Driver protocol
  1.  ;  DGQUIET = if set to 1, no user interaction
  1.  ;  BSDCLN  = if set, ien to clinic
  1.  ;  BSDDELV = if set, delivery message (who, where, phone)
  1.  ;  BSDADT  = ien of admission in file 405
  1.  ;  ** I $G(DGQUIET) then Chart Request Printer must be set in
  1.  ;      IHS Scheduling Parameter file
  1.  ;
  1.  ; quit if parameter not turned on
  1.  NEW DIV
  1.  S DIV=$$DIV^BDGPAR(DUZ(2)) Q:'DIV
  1.  Q:$$GET1^DIQ(9009020.1,DIV,.09)'="YES"
  1.  ;
  1.  ; first get chart request clinic
  1.  I '$G(BSDCLN) D  Q:$G(BSDCLN)<1
  1.  . ; if not sent and in quiet mode, get clinic from parameter file
  1.  . I $G(DGQUIET) S BSDCLN=$$GET1^DIQ(9009020.1,DIV,.11,"I") Q
  1.  . ;
  1.  . ; else, ask for clinic with parameter file entry as default
  1.  . W !!,"Requesting Chart for new admission.  Type ^ to bypass."
  1.  . K DIC S DIC="^SC(",DIC(0)="AEQM",DIC("W")=$$INACTMSG^BSDU
  1.  . S DIC("B")=$$GET1^DIQ(9009020.1,DIV,.11)    ;default
  1.  . S DIC("S")="I $P(^(0),U,3)=""C"""
  1.  . S DIC("A")="Select Clinic Name: "
  1.  . D ^DIC K DIC S BSDCLN=+Y
  1.  ;
  1.  ; next find out to whom it is to be delivered
  1.  I $G(BSDDELV)="" D  Q:$G(BSDDELV)=""
  1.  . ; if not sent and in quiet mode, use user name & office phone
  1.  . I $G(DGQUIET) S BSDDELV="New Admission - Deliver Chart to "_$$GET1^DIQ(405,+$G(BSDADT),.06)_" Ward" Q
  1.  . ;
  1.  . ; else ask user
  1.  . S BSDDELV=$$DELIVER^BSDAPP       ;see subrtn above for details
  1.  ;
  1.  ; next stuff chart request into file (code from ^SDAPP)
  1.  NEW DIC,X,DLAYGO,DINUM,DD,DO,Y,DIE,DA,DR
  1.  ;
  1.  ;  add today's date if not there
  1.  I '$D(^SC(BSDCLN,"C",DT,0)) D  Q:Y<1
  1.  . S DIC="^SC("_BSDCLN_",""C"",",X=DT,DIC(0)="L",DLAYGO=44.006
  1.  . S DIC("P")="44.006DA",DINUM=DT,DA(1)=BSDCLN
  1.  . L +^SC(BSDCLN,"C"):3 I '$T S Y=0 Q
  1.  . K DD,DO D FILE^DICN L -^SC(BSDCLN,"C")
  1.  . I Y<1 W:'$D(DGQUIET) !,"Error filing chart request!!!"
  1.  ;
  1.  ;  now add patient to today's list
  1.  S DIC="^SC("_BSDCLN_",""C"","_DT_",1,",DIC(0)="L",DLAYGO=44.007
  1.  S DIC("P")="44.007PA",X=DFN,DA(2)=BSDCLN,DA(1)=DT
  1.  L +^SC(BSDCLN,"C",DT):3 I '$T S Y=0 Q
  1.  K DD,DO D FILE^DICN L -^SC(BSDCLN,"C",DT)
  1.  I Y<1 W:'$D(DGQUIET) !,"Error filing chart request!!!" Q
  1.  ;
  1.  ;  add other data items
  1.  S DIE="^SC("_BSDCLN_",""C"","_DT_",1,"
  1.  S DA=+Y,DA(1)=DT,DA(2)=BSDCLN
  1.  S DR="9999999.01///"_$$NOW^XLFDT_";9999999.02///"_DUZ
  1.  S DR=DR_";9999999.03///"_BSDDELV
  1.  D ^DIE
  1.  ;
  1.  ; now print request
  1.  D PRINT^BSDAPP(BSDCLN,1)
  1.  Q
  1.  ;