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

DVBAREG2.m

Go to the documentation of this file. 
  1. DVBAREG2 ;ALB/JLU;second half of the 7131 input;3/2/99
  1.  ;;2.7;AMIE;**3,5,14,17,20,25**;Apr 10, 1995
  1.  ;
  1. CONT ;asks selection from list
  1.  S DIR(0)="NAO^1:"_X1_":0"
  1.  S DIR("A")="Select 1-"_X1_"   or '^' to Exit or Return to continue "
  1.  D ^DIR
  1.  K DIR
  1.  I $D(DTOUT)!$D(DUOUT) S DVBASTOP=1 Q
  1.  I Y]"" S DVBANS=Y
  1.  E  K DVBANS
  1.  Q
  1.  ;
  1. SINGLE ;when select single entry point
  1.  S XTYPE=""
  1.  S X1=$O(^TMP("DVBA",$J,0))
  1.  I X1="" S DVBASTOP=1 Q
  1.  S XTYPE=$O(^TMP("DVBA",$J,X1,XTYPE))
  1.  I XTYPE="" S DVBASTOP=1 Q
  1.  S DIR("A",1)=""
  1.  S DIR("A",2)=$P(^TMP("DVBA",$J,X1,XTYPE),U)
  1.  S DIR("A")="Is this the correct information? "
  1.  S DIR("B")="NO"
  1.  S DIR(0)="YA"
  1.  D ^DIR
  1.  K DIR
  1.  I $D(DUOUT)!($D(DTOUT)) S DVBASTOP=1 Q
  1.  I Y S DVBANS=X1,DVBTYPE=XTYPE,DVBDOC=$S(DVBTYPE["ADMISSION":"A",1:"L")
  1.  E  K DVBANS
  1.  Q
  1.  ;
  1. DTRNG(DFN) ;gets date range from user
  1.  S DIR("A",1)="Display Admission or Activity information"
  1.  S DIR("A")="for "_$P(DFN,U,2)_"  by"
  1.  S DIR("?")="Date Range will allow the user to select the specific dates."
  1.  S DIR("?",1)="All Dates will show the user all possible information."
  1.  S DIR(0)="SM^D:Date Range;A:All Dates"
  1.  D ^DIR
  1.  K DIR
  1.  I $D(DTOUT)!($D(DUOUT)) S DVBAQUIT=1 Q
  1.  I X="" S DVBASTOP=1 Q
  1.  S DVBBDT=0,DVBEDT=0
  1.  S VAR(1,0)="0,0,0,1,0^"
  1.  D WR^DVBAUTL4("VAR")
  1.  K VAR
  1.  I Y="D" DO
  1.  .D DATE^DVBCUTL4(.DVBBDT,.DVBEDT)
  1.  .S Y="D"
  1.  .I DVBBDT>0,'+$P(DVBBDT,".",2) S DVBBDT=DVBBDT-.0000001
  1.  .I DVBEDT>0,'+$P(DVBEDT,".",2) S DVBEDT=DVBEDT+.9999999
  1.  .I DVBBDT=0,DVBEDT=0 S DVBAQUIT=1
  1.  .I DVBBDT=-1,DVBEDT=-1 S DVBASTOP=1
  1.  .Q
  1.  Q
  1.  ;
  1. CLEAN ;cleans up variables
  1.  K DA,ADM,ADMDT,ADMNUM,DFN,DIC,A,DR,PNAM,SSN,TRN,Z,DINUM,DTAR,C,J,K,L,C,D,DIE,ONFILE,%,OLDDA,%Y,DIK,ZI,X,Y,AROWOUT,DVBAEDT,DVBAENTR,DVBASTOP,DVBREQDT,DVBANS,DVBTYPE
  1.  K ^TMP("DVBA",$J),^UTILITY("DIQ1",$J)
  1.  Q
  1.  ;
  1. PAGE ;pages/dispays end of page/screen
  1.  S VAR(1,0)="0,0,0,0,1^"
  1.  S VAR(2,0)="0,0,"_(IOM-$L(HD)\2)_":0,0,0^"_HD
  1.  S VAR(3,0)="0,0,"_(IOM-$L(HNAME)\2)_":0,1:2,0^"_HNAME
  1.  D WR^DVBAUTL4("VAR")
  1.  K VAR
  1.  Q
  1.  ;
  1. SELECT ;checks doc type, request status and calls deletion, if necessary
  1.  N ZI
  1.  K DVBAENTR
  1.  S DVBREQDT=9999999.9999999-DVBANS
  1.  I DVBTYPE["ADMISSION" DO
  1.  .S ADMNUM=$P(^TMP("DVBA",$J,DVBANS,DVBTYPE),U,2)
  1.  D COMPSEL
  1.  Q
  1.  ;
  1. COMPSEL ;** Compare selected 7131 to existing
  1.  N DVBATMPT
  1.  I DVBTYPE["ADMISSION" S DVBATMPT="A"
  1.  I DVBTYPE'["ADMISSION" S DVBATMPT="L"
  1.  F ZI=0:0 S ZI=$O(^DVB(396,"B",+DFN,ZI)) Q:ZI=""  I $D(^DVB(396,"G",+$E(DVBREQDT,1,14),ZI))&(DVBATMPT=$P(^DVB(396,ZI,2),"^",10)) S DVBAENTR=ZI Q
  1.  I $D(DVBAENTR) DO
  1.  .D ALERT(ZI)
  1.  .D ASK
  1.  .Q:$D(DVBAQUIT)!($D(DVBASTOP))
  1.  .I '$$LOCK^DVBAUTL6(DVBAENTR) S DVBASTOP=1 Q
  1.  .S STAT=$P(^DVB(396,DVBAENTR,1),U,12)
  1.  .S ONFILE=0
  1.  .I STAT'="" D ALERT1
  1.  .Q:$D(DVBAQUIT)!($D(DVBASTOP))
  1.  .I ONFILE=1 S DVBASTOP=1 Q
  1.  .Q
  1.  I '$D(DVBAENTR) DO
  1.  .D DICW^DVBAUTIL
  1.  .D ASK1
  1.  .I $D(DVBASTOP)!($D(DVBAQUIT)) Q
  1.  .D STUFF
  1.  .Q
  1.  I '$D(DVBAENTR) S DVBASTOP=1
  1.  Q
  1.  ;
  1. ALERT(Y) ;displays when a potential hit in the 7131 file.
  1.  S VAR(1,0)="1,0,0,2,0^There is a 7131 already on file for "_$$FMTE^XLFDT(DVBREQDT,"5DZ")
  1.  S STAT=$P(^DVB(396,+Y,1),U,12)
  1.  S VAR(2,0)="0,0,0,1:1,0^Status is "_$S(STAT'="":"FINALIZED",1:"OPEN")
  1.  D WR^DVBAUTL4("VAR")
  1.  K VAR
  1.  Q
  1. ALERT1 ;
  1.  I STAT'="" DO
  1.  .S VAR(1,0)="0,0,0,1,0^"
  1.  .D WR^DVBAUTL4("VAR")
  1.  .K VAR
  1.  .S DIR("A")="Do you want to delete the existing 7131 for this date: "
  1.  .S DIR(0)="YAO"
  1.  .S DIR("B")="NO"
  1.  .S DIR("?")="Answer YES or No.  You may not have two 7131s for the same admission date."
  1.  .D ^DIR
  1.  .K DIR
  1.  .I $D(DTOUT)!($D(DUOUT))!(Y="") S DVBAQUIT=1 Q
  1.  .I 'Y S DVBASTOP=1 Q
  1.  .I Y DO
  1.  ..S DA=+DVBAENTR
  1.  ..D REOPEN^DVBAUTL2
  1.  ..K DA
  1.  ..Q
  1.  .Q
  1.  Q
  1.  ;
  1. ASK1 ;ask user if wish to add new 7131
  1.  S DVBAASIH=$P(DVBREQDT,".",2) ;*ASIH admit? (P4,v2.7)
  1.  D:$L(DVBAASIH)>6 ASIHALRT^DVBAUTL8 ;**Warn ASIH admit
  1.  S VAR(1,0)="1,0,0,1,0^"
  1.  D WR^DVBAUTL4("VAR")
  1.  K VAR
  1.  S DIR("A",1)="Do you want to add a NEW 7131"
  1.  S DIR("A")="for "_$P(PNAM,",",2,99)_" "_$P(PNAM,",",1,1)_" :"
  1.  S DIR(0)="YAO"
  1.  S DIR("B")="NO"
  1.  S DIR("?")="'YES' to enter a new 7131. 'NO' to search for an existing one."
  1.  D ^DIR
  1.  K DIR,DVBAASIH
  1.  I $D(DUOUT)!($D(DTOUT)) S DVBAQUIT=1 Q
  1.  S:Y=1 DVBREQDT=+$E(DVBREQDT,1,14)
  1.  I Y=0 S DVBASTOP=1 Q
  1.  Q
  1.  ;
  1. ASK ;ask the user if wish to edit existing 7131
  1.  S VAR(1,0)="1,0,0,1,0^"
  1.  D WR^DVBAUTL4("VAR")
  1.  K VAR
  1.  S DIR("A")="Are you sure you want to edit this 7131 request: "
  1.  S DIR("B")="NO"
  1.  S DIR("?")="'YES' to edit the 7131 request."
  1.  S DIR(0)="YAO"
  1.  D ^DIR
  1.  K DIR
  1.  I $D(DUOUT)!($D(DTOUT)) S DVBAQUIT=1 Q
  1.  I Y=0 S DVBASTOP=1 Q
  1.  I Y=1 S DVBAEDT=1
  1.  Q
  1.  ;
  1. STUFF ;enters 7131 into 7131 form file
  1.  K DA,DIC("S"),DD,DO
  1.  S DLAYGO=396,DIC(0)="QLM",DIC="^DVB(396,",X=+DFN
  1.  D FILE^DICN
  1.  I 'Y DO  S DVBASTOP=1 Q
  1.  .S VAR(1,0)="1,0,0,2,0^Unable to add this new record!"
  1.  .D WR^DVBAUTL4("VAR")
  1.  .K VAR
  1.  .Q
  1.  I '$$LOCK^DVBAUTL6(Y) S DVBASTOP=1 Q
  1.  S (DA,DVBAENTR)=+Y
  1.  S DR="1////"_CNUM_";2////"_SSN_";3////"_DVBREQDT_";23////"_DT_";24////"_DT_";27////"_LOC_";28////"_OPER_";30////"_$S($D(ADMNUM):"A",1:"L")
  1.  S DIE=DIC
  1.  D ^DIE
  1.  K DA,DLAYGO,DIC,DIE
  1.  Q
  1.  ;