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

BDGDSA.m

Go to the documentation of this file. 
  1. BDGDSA ;IHS/ITSC/WAR - ENTER/EDIT DAY SURGERY  [ 01/07/2005  5:08 PM ]
  1.  ;;5.3;PIMS;**1001,1003,1004,1005,1010,1011,1012**;MAY 28, 2004
  1.  ;IHS/ITSC/LJF 06/22/2005 PATCH 1003 set DFN properly so entries without zero nodes are not used
  1.  ;IHS/OIT/LJF  08/26/2005 PATCH 1004 search for visit already created but ignore time
  1.  ;             11/09/2005 PATCH 1004 added check in case entry was deleted
  1.  ;             05/04/2006 PATCH 1005 if default visit type not set in one file, check another
  1.  ;cmi/anch/maw 11/20/2008 PATCH 1010 added call to day surgery movement event driver
  1.  ;
  1.  ;This was a rewrite of ADGDSA. Basic logic for this rtn...
  1.  ; DFN is used as a switch for processing, looping or quiting.
  1.  ;If DFN is positive... keep processing
  1.  ;If DFN is negitive... do the main loop (F  Q:'DFN  D)
  1.  ;If DFN is zero... quit this routine
  1.  ;
  1.  ;IHS/ITSC/WAR 4/14/04 IHS/ITSC/WAR 5/4/2004 PATCH #1001 mod for DUZ(2)
  1.  ;I '$$GET1^DIQ(9009020.1,1,.15,"I") D
  1.  ;I '$$GET1^DIQ(9009020.1,$O(^DG(40.8,"C",DUZ(2),0)),.15,"I") D  ;cmi/maw 9/1/09 orig line PATCH 1011
  1.  I '$$GET1^DIQ(9009020.1,$O(^DG(40.8,"AD",DUZ(2),0)),.15,"I") D  ;cmi/maw 9/1/09 mod line PATCH 1011
  1.  .W $C(7)
  1.  .W !!,"You must have a valid Clinic entered in the DAY SURGERY"
  1.  .W !,"HOSP LOCATION, found in the ADT parameters set up",!!!
  1.  .D PAUSE^BDGF
  1.  E  D
  1.  .S DFN=-1
  1.  .S (BDGDSVST,DGA,DGX,DGDFN1,ADGDFN)=""
  1.  .F  Q:'DFN  D
  1.  ..D NAME
  1.  ..I DFN>0 D
  1.  ...S DA=DFN
  1.  ...D EN^ADGPI
  1.  ...I +$G(DUOUT)=1 S DFN=DFN*-1  ;User uphatted out
  1.  ...I DFN>0 D DECEASED
  1.  ...S TRUE=$S(DFN<0:1,1:0)       ;Used by 'FOR' Loop in DSDTLOCK
  1.  ...D DSDTLOCK
  1.  ...I DFN>0 D  ;Creates or edits the DS record
  1.  ....S DIDEL=9009012,DR="[ADGDSADD]",DIE="^ADGDS(",DA=DFN
  1.  ....S DIE("NO^")="" D ^DIE L -^ADGDS(DFN) K DIE("NO^")
  1.  ....;ADD CODE... if record deleted DO DELETE (visit etc)
  1.  ....I '$D(^ADGDS(DFN,"DS",DGDFN1,0)) D  Q  ;cmi/maw PATCH 1010 RQMT 14 delete the visit if they delete day surgery
  1.  ..... D DELETE(DFN,DGDSDT)
  1.  ...I DFN>0 D DSWKSHT  ;DaySurg Worksheet
  1.  ...I DFN>0 D PCCVSIT  ;Create PCC visit
  1.  ...I DFN>0 D MOVE^BDGDSEVT  ;cmi/maw 11/20/2008 PATCH 1010 RQMT 14 added day surgery event driver
  1.  ...I DFN>0 D
  1.  ....I $D(^ADGDS(DFN,"DS",DGDFN1,2)),$P(^(2),U)'="" D DSIC
  1.  D KILL^ADGUTIL K ADGDFN,ADGDFN1,BDGDSVST,DGA,DGX,DGDFN1
  1.  Q
  1.  ;
  1. NAME ;*** Get Pt name
  1.  K DIC,DAT,DFN
  1.  W !! S DIC=9009012,DLAYGO=9009012,DIC(0)="AQEML"
  1.  S DIC("A")="Select Day Surgery Patient: "
  1.  ;set DIC("S") to check for unregistered patients
  1.  S DIC("S")="I $D(^AUPNPAT(+Y,41,DUZ(2),0)),$P(^(0),U,2)'="""""
  1.  D ^DIC K DIC("A")
  1.  ;
  1.  ;IHS/ITSC/LJF 6/22/2005 PATCH 1003 set DFN properly
  1.  S DFN=+Y
  1.  ;I +$G(DFN)=0!(+$G(DUOUT)=1) S DFN=0  ;User wants to quit
  1.  I +$G(DFN)<1!(+$G(DUOUT)=1) S DFN=0  ;User wants to quit
  1.  ;
  1.  Q
  1.  ;
  1. DECEASED ;
  1.  I $D(^DPT(DFN,.35)),$P(^(.35),U)]"" D
  1.  . K DIR S DIR(0)="Y"
  1.  . S DIR("A")="This patient has died.  Sure you want to continue"
  1.  . S DIR("B")="NO" D ^DIR
  1.  .I Y=0 S DFN=DFN*-1
  1.  Q
  1.  ;
  1. DSDTLOCK ;Get DS date and check for locks
  1.  F  Q:TRUE  D
  1.  .K DIC S:'$D(^ADGDS(DFN,"DS",0)) ^(0)="^9009012.01D^^"
  1.  .S DIC="^ADGDS("_DFN_",""DS"",",DLAYGO=9009012,DIC(0)="AEQMZL"
  1.  .S DA(1)=DFN,DA=0,DGA=$P(^ADGDS(DFN,"DS",0),U,3)
  1.  .I DGA'=""!($O(^ADGDS(DFN,"DS",0))) D
  1.  ..S DIC("B")=$S('$D(^ADGDS(DFN,"DS",DGA,2)):DGA,$P(^(2),U)="":DGA,1:"")
  1.  .;
  1.  .L +^ADGDS(DFN,"DS"):3 I '$T D
  1.  ..W !,*7,"SOMEONE IS UPDATING THIS DAY SURGERY PATIENT; TRY AGAIN LATER"
  1.  ..S TRUE=1,DFN=(DFN*-1)
  1.  .I DFN>0 D
  1.  ..D ^DIC L -^ADGDS(DFN,"DS") W !! K DIC,DIC("A")
  1.  ..I Y'>0 D
  1.  ...S TRUE=1,DFN=(DFN*-1)
  1.  ..E  D
  1.  ...S DGDFN1=+Y
  1.  ...S DGDSDT=+$G(^ADGDS(DFN,"DS",DGDFN1,0))  ;cmi/maw 5/15/2009 added for day surgery date to delete stuff with
  1.  .;
  1.  .I DFN>0 D
  1.  ..I 'TRUE,$D(^ADGDS(DFN,"DS",DGDFN1,2)),$P(^(2),U)'="" D
  1.  ...W !?5,*7,"Past day surgeries must be edited in the Edit Past Day Surhery option",!
  1.  ..E  D
  1.  ...L +^ADGDS(DFN):3
  1.  ...I '$T D
  1.  ....W !,*7,"SOMEONE IS UPDATING THIS ENTRY; TRY AGAIN LATER"
  1.  ....S DFN=DFN*-1
  1.  ...E  D
  1.  ....S TRUE=1
  1.  Q
  1. DSWKSHT ;Day Surg worksheet
  1.  K DIR S DIR("A")="Print Day Surgery Worksheet",DIR(0)="Y"
  1.  S DIR("?")="Enter YES to print a worksheet for this patient"
  1.  S DIR("B")="NO" D ^DIR
  1.  I Y=1 D
  1.  .S ADGDFN=DFN,ADGDFN1=DGDFN1 D DS1^ADGCRB0 S DFN=ADGDFN,DGDFN1=ADGDFN1
  1.  Q
  1.  ;
  1. DELETE(DF,DSDT) ;-- delete the day surgery and visit PATCH 1010 RQMT 13
  1.  N BDGDSVST,FOUND
  1.  S (BDGDSVST,FOUND)=0
  1.  F  S BDGDSVST=$O(^AUPNVSIT("AA",DF,DSDT,BDGDSVST)) Q:BDGDSVST=""!(FOUND)  D
  1.  .I $P(^AUPNVSIT(BDGDSVST,0),U,7)="S" D  ;Day Surgery vst
  1.  ..I $P(^AUPNVSIT(BDGDSVST,0),U,6)=DUZ(2) S FOUND=BDGDSVST
  1.  Q:'$G(FOUND)
  1.  Q:$P($G(^AUPNVSIT(FOUND,0)),U,9)  ;don't continue if more dependent entry count is greater than 0
  1.  S APCDVDLT=FOUND
  1.  D ^APCDVDLT
  1.  Q
  1.  ;
  1. PCCVSIT ;***> create visit in PCC for day surgery
  1.  S PKG=$O(^DIC(9.4,"C","PIMS",0))                 ;Get IEN for PIMS pkg
  1.  ;
  1.  ;If OP only site OR 'PASS DATA TO PCC' in PCC MastrCntl file not YES
  1.  ;I $P(^DG(40.8,$O(^DG(40.8,"C",DUZ(2),0)),0),"^",3)!('+$P($G(^APCCCTRL(DUZ(2),11,PKG,0)),U,2)) D  ;cmi/maw 9/1/09 orig line PATCH 1011
  1.  I $P(^DG(40.8,$O(^DG(40.8,"AD",DUZ(2),0)),0),"^",3)!('+$P($G(^APCCCTRL(DUZ(2),11,PKG,0)),U,2)) D  ;cmi/maw 9/1/09 mod line PATCH 1011
  1.  .W !!,"Outpatient only site 'OR' PCC link not setup - visit not created"
  1.  .S DFN=0
  1.  E  D
  1.  .;
  1.  .;IHS/OIT/LJF 11/09/2005 PATCH 1004 prevent error in case of deletions
  1.  .;S APCDALVR("APCDDATE")=+^ADGDS(DFN,"DS",DGDFN1,0)  ;visit date
  1.  .S APCDALVR("APCDDATE")=+$G(^ADGDS(DFN,"DS",DGDFN1,0)) Q:'APCDALVR("APCDDATE")  ;visit date
  1.  .;
  1.  .;check if visit already exists
  1.  .S DGX=APCDALVR("APCDDATE"),DGX1=9999999-$P(DGX,".")_"."_$P(DGX,".",2)
  1.  .;
  1.  .D FINDVST(.DGX1)    ;IHS/OIT/LJF 8/26/2005 PATCH 1004 reset date/time to checked in visit
  1.  .;
  1.  .I $D(^AUPNVSIT("AA",DFN,DGX1)) D
  1.  ..N A  S A=0
  1.  ..F  S A=$O(^AUPNVSIT("AA",DFN,DGX1,A)) Q:A=""!(DFN<0)  D
  1.  ...I $P(^AUPNVSIT(A,0),U,7)="S" S DFN=DFN*-1,BDGDSVST=A  ;visit found
  1.  ...W !!,"Day Surgery VISIT was found..."
  1.  .I DFN>0 D
  1.  ..; Visit not found, so create one
  1.  ..S APCDALVR("APCDADD")=1 D APCDEIN^ADGCALLS  ;initialize PCC variables
  1.  ..W !!,"Day Surgery VISIT being created..."
  1.  ..S APCDALVR("APCDPAT")=DFN,APCDALVR("APCDLOC")=APCDDUZ2
  1.  ..;IHS/ITSC/WAR 4/14/04 Add Hosp Loc
  1.  ..S APCDALVR("APCDHL")=$$GET1^DIQ(9009020.1,1,.15,"I")
  1.  ..;IHS/ITSC/WAR 1/28/04 Mod to handle different types of Facilities
  1.  ..;S APCDALVR("APCDTYPE")="I",APCDALVR("APCDCAT")="S"
  1.  ..S APCDALVR("APCDTYPE")=$$GET1^DIQ(9001001.2,APCDALVR("APCDLOC"),.11,"I"),APCDALVR("APCDCAT")="S"
  1.  ..I APCDALVR("APCDTYPE")="" S APCDALVR("APCDTYPE")=$$GET1^DIQ(9001000,DUZ(2),.04,"I")  ;IHS/OIT/LJF 05/04/2006 PATCH 1005
  1.  ..S APCDALVR("APCDCLN")="DAY SURGERY" D DSCV^ADGCALLS K AUPNSEX
  1.  ..;
  1.  ..S APCDALVR("APCDDATE")=+^ADGDS(DFN,"DS",DGDFN1,0)  ;visit date
  1.  ..;get visit entry
  1.  ..S DGX=APCDALVR("APCDDATE"),DGX1=9999999-$P(DGX,".")_"."_$P(DGX,".",2)
  1.  ..K APCDALVR
  1.  ..S (BDGDSVST,FOUND)=0
  1.  ..F  S BDGDSVST=$O(^AUPNVSIT("AA",DFN,DGX1,BDGDSVST)) Q:BDGDSVST=""!(FOUND)  D
  1.  ...I $P(^AUPNVSIT(BDGDSVST,0),U,7)="S" D  ;Day Surgery vst
  1.  ....I $P(^AUPNVSIT(BDGDSVST,0),U,6)=DUZ(2) S FOUND=BDGDSVST
  1.  ..S BDGDSVST=FOUND
  1.  ..I +BDGDSVST=0 W !!,*7,"VISIT ERROR, Please notify your supervisor!" D
  1.  ...S DFN=0
  1.  .E  D
  1.  ..S DFN=DFN*-1  ; reset the DFN to positive
  1.  Q
  1.  ;
  1. DSIC ;***> create incomplete chart entry
  1.  ;IHS/ITSC/WAR 12/10/03 This section copied from BDGICEVT and modified
  1.  ;
  1.  S (BDGICREC,X)=""
  1.  F  S X=$O(^BDGIC("B",DFN,X)) Q:X=""!(BDGICREC)  D
  1.  .;Check IC Disch date/time v.s. DaySurg Release date/time
  1.  .I $P(^BDGIC(X,0),U,2)=$P(^ADGDS(DFN,"DS",DGDFN1,2),U,1) S BDGICREC=X
  1.  I +BDGICREC=0 D
  1.  .S VST=BDGDSVST
  1.  .S SERV=+$P(^ADGDS(DFN,"DS",DGDFN1,0),U,5)
  1.  .S SRDATE=DGX
  1.  .W !!,"Creating entry in Incomplete Chart file....",! K DIC
  1.  .; make FM call to stuff data
  1.  .S X=DFN,DIC="^BDGIC(",DLAYGO=9009016.1,DIC(0)="L"
  1.  .; 4 slash visit to bypass file screen
  1.  .S DIC("DR")=".03////"_VST_";.04///`"_SERV_";.05///"_(SRDATE\1)
  1.  .L +^BDGIC(0):3 I '$T D
  1.  .. Q:$D(DGQUIET)
  1.  .. W !,*7,"CANNOT ADD TO INCOMPLETE CHART FILE;"
  1.  .. W "BEING UPDATED BY SOMEONE ELSE"
  1.  K DD,DO D FILE^DICN L -^BDGIC(0)
  1.  K APCDALVR
  1.  Q
  1.  ;
  1. LASTDS(BDGDT,DFN)    ;EP; IP AdmDate and Pt being passed to this tag
  1.  ;Get Pt's most recent DaySurg visit as it relates to IP Adm date
  1.  ;Release date from DaySurg will be passed back in DSDATE
  1.  ;If no release date entered yet, Admit date passed back in DSDATE
  1.  S DSDATE=0
  1.  I $G(^ADGDS(DFN,0)) D         ;Pt has at least one entry
  1.  .S BDGDT=$O(^ADGDS(DFN,"DS","AA",BDGDT),-1)
  1.  .I BDGDT'="" D
  1.  ..S IEN=$O(^ADGDS(DFN,"DS","AA",BDGDT,0))        ;Get rec#
  1.  ..I IEN S DSDATE=+$G(^ADGDS(DFN,"DS",IEN,2))  ;Get release date
  1.  ..;Assumption - if NO release date entered yet
  1.  ..I 'DSDATE S DSDATE=BDGDT      ;return DaySurg ADMIT date
  1.  Q DSDATE
  1.  ;
  1. DSPROC(BDGDT,DFN)     ;IP AdmDate and Pt being passed to this tag
  1.  ;Get free text PROCedure (if there)
  1.  S DSPROC=0
  1.  I $G(^ADGDS(DFN,0)) D         ;Pt has at least one entry
  1.  .S BDGDT=$O(^ADGDS(DFN,"DS","AA",BDGDT),-1)
  1.  .I BDGDT'="" D
  1.  ..S IEN=$O(^ADGDS(DFN,"DS","AA",BDGDT,0))          ;Get rec#
  1.  ..I +IEN  D
  1.  ...S DSDATE=+$G(^ADGDS(DFN,"DS",IEN,2))         ;Get release date
  1.  ...S DSPROC=$P($G(^ADGDS(DFN,"DS",IEN,0)),U,2)  ;Get procedure
  1.  Q DSPROC
  1.  ;
  1. DSDISP(DT,DFN)     ;IP AdmDate and Pt being passed to this tag 
  1.  ;Get the DISPosition (if there) - none stored as of 3/4/04 WAR
  1.  S DSDISP=0
  1.  ;
  1.  ;
  1.  Q DSDISP
  1.  ;
  1.  ;IHS/OIT/LJF 8/26/2005 PATCH 1004 new subroutine added
  1. FINDVST(DATE) ; reset date/time to that for a day surgery visit if one exists
  1.  ;temporary fix until day surgery rewrite
  1.  NEW DATE1,IEN,FOUND
  1.  S FOUND=0
  1.  S DATE1=DATE\1    ;take off time
  1.  F  S DATE1=$O(^AUPNVSIT("AA",DFN,DATE1)) Q:'DATE1  Q:((DATE1\1)'=(DATE\1))  Q:FOUND  D
  1.  . S IEN=0 F  S IEN=$O(^AUPNVSIT("AA",DFN,DATE1,IEN)) Q:'IEN  Q:FOUND  D
  1.  .. I $P(^AUPNVSIT(IEN,0),U,7)="S" S FOUND=1,DATE=DATE1
  1.  Q