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

BDGF.m

Go to the documentation of this file. 
  1. BDGF ; IHS/ANMC/LJF - GENERAL PIMS FUNCTION CALLS ;  [ 01/09/2004  8:07 AM ]
  1.  ;;5.3;PIMS;**1003,1005,1007,1008**;MAY 28, 2004
  1.  ;IHS/ITSC/LJF 05/13/2005 PATCH 1003 added EP; to MSG subroutine
  1.  ;IHS/OIT/LJF  12/30/2005 PATCH 1005 added WRAP subroutine
  1.  ;             01/20/2006 PATCH 1005 added READRVD subroutine
  1.  ;cmi/anch/maw 2/22/2007 PATCH 1007 item 1007.39 modified ZIS to accept copies
  1.  ;
  1. WRAP(STRING,COL,ARRAY) ;EP return string formatted by colum width;IHS/OIT/LJF 12/30/2005 PATCH 1005
  1.  ; returns multiple lines in ARRAY; COL=column width
  1.  K ^UTILITY($J,"W")
  1.  NEW X,DIWL,DIWR,DIWF,I
  1.  S X=STRING,DIWL=0,DIWR=COL,DIWF="C"_COL
  1.  D ^DIWP
  1.  F I=1:1 Q:'$D(^UTILITY($J,"W",DIWL,I))  S ARRAY(I)=^UTILITY($J,"W",DIWL,I,0)
  1.  K ^UTILITY($J,"W")
  1.  Q
  1.  ;
  1. IHS() ;EP; returns 1 if agency of user is IHS   
  1.  Q $S($G(DUZ("AG"))="I":1,1:0)
  1.  ;
  1. MSG(DATA,PRE,POST) ;EP; -- writes line to device;IHS/ITSC/LJF PATCH 1003
  1.  NEW I,FORMAT
  1.  S FORMAT="" I $G(PRE)>0 F I=1:1:PRE S FORMAT=FORMAT_"!"
  1.  D EN^DDIOL(DATA,"",FORMAT)
  1.  I $G(POST)>0 F I=1:1:POST D EN^DDIOL("","","!")
  1.  Q
  1.  ;
  1. PAUSE ;EP; -- ask user to press return - no form feed
  1.  NEW DIR Q:IOST'["C-"
  1.  S DIR(0)="E",DIR("A")="Press ENTER to continue" D ^DIR
  1.  Q
  1.  ;
  1. ZIS(X,BDGRTN,BDGDESC,BDGVAR,BDGDEV) ;EP
  1.  ; -- called to select device and send print
  1.  K %ZIS,IOP,ZTIO   ;IHS/ITSC/LJF 1/9/2004 added ZTIO
  1.  I X="F" D     ;forced queuing; no user interaction
  1.  . S ZTIO=BDGDEV,ZTDTH=$H
  1.  ;cmi/anch/maw 2/22/2007 modified print logic to accept copies PATCH 1007 item 1007.39
  1.  I X'="F" D  Q:'$D(IO("Q"))
  1.  . S %ZIS=X
  1.  . I $G(BDGDEV)]"" S %ZIS("B")=BDGDEV
  1.  . D ^%ZIS
  1.  . Q:POP
  1.  . Q:$D(IO("Q"))
  1.  . I $G(BDGCOP)>1 D  Q
  1.  .. N J  ;cmi/anch/maw 7/10/2007 modified new to kill patch 1007
  1.  .. F J=1:1:BDGCOP D @BDGRTN
  1.  . D @BDGRTN
  1.  ;cmi/anch/maw 2/22/2007 end of mods
  1.  ;cmi/anch/maw 2/22/2007 next 3 lines are original lines
  1.  ;E  D   Q:POP  I '$D(IO("Q")) D @BDGRTN Q
  1.  ;. S %ZIS=X I $G(BDGDEV)]"" S %ZIS("B")=BDGDEV
  1.  ;. D ^%ZIS
  1.  ;cmi/anch/maw 2/22/2007 end of orig lines
  1.  ;
  1.  ;cmi/anch/maw 2/22/2007 added flag for copies if passed in PATCH 1007 item 1007.39
  1.  I $G(BDGCOP)>1 D  Q
  1.  . N K  ;cmi/maw 10/3/2007 changed to k from j
  1.  . F K=1:1:BDGCOP D  ;cmi/maw 10/3/2007 changed from k to j
  1.  .. K IO("Q") S ZTRTN=BDGRTN,ZTDESC=BDGDESC
  1.  .. I $G(BDGDTH)]"" S ZTDTH=BDGDTH  ;if time is already put in then set to that cmi/maw 10/3/2007
  1.  .. F I=1:1 S J=$P(BDGVAR,";",I) Q:J=""  S ZTSAVE(J)=""
  1.  .. D ^%ZTLOAD
  1.  .. S BDGDTH=$G(ZTSK("D"))  ;set time equal to what they put in the first time  cmi/maw 10/3/2007
  1.  .. K ZTSK
  1.  . D ^%ZISC
  1.  . K BDGDTH  ;cmi/maw 10/3/2007
  1.  ;cmi/anch/maw 2/22/2007 end of mods PATCH 1007 item 1007.39
  1.  K IO("Q") S ZTRTN=BDGRTN,ZTDESC=BDGDESC
  1.  F I=1:1 S J=$P(BDGVAR,";",I) Q:J=""  S ZTSAVE(J)=""
  1.  D ^%ZTLOAD K ZTSK D ^%ZISC
  1.  Q
  1.  ;
  1. READ(TYPE,PROMPT,DEFAULT,HELP,SCREEN,DIRA) ;EP; calls reader, returns response
  1.  NEW DIR,Y,DIRUT
  1.  S DIR(0)=TYPE
  1.  I $E(TYPE,1)="P",$P(TYPE,":",2)["L" S DLAYGO=+$P(TYPE,U,2)
  1.  I $D(SCREEN) S DIR("S")=SCREEN
  1.  I $G(PROMPT)]"" S DIR("A")=PROMPT
  1.  I $G(DEFAULT)]"" S DIR("B")=DEFAULT
  1.  I $D(HELP) S DIR("?")=HELP
  1.  I $D(DIRA(1)) S Y=0 F  S Y=$O(DIRA(Y)) Q:Y=""  S DIR("A",Y)=DIRA(Y)
  1.  D ^DIR
  1.  Q Y
  1.  ;
  1. TIME(DATE) ;EP returns time in 12:00 PM format for date send
  1.  Q $$UP^XLFSTR($E($$FMTE^XLFDT($E(DATE,1,12),"P"),14,21))
  1.  ;
  1. NUMDATE(D,YR) ;EP; returns external number date with leading zeros
  1.  ; D=date and optionally time
  1.  ; YR=1 for 2 digit year, =0 for 4 digit year
  1.  NEW X
  1.  I 'D Q ""
  1.  I $G(YR) S X=$E(D,4,5)_"/"_$E(D,6,7)_"/"_$E(D,2,3)
  1.  E  S X=$E(D,4,5)_"/"_$E(D,6,7)_"/"_(1700+$E(D,1,3))
  1.  I $L(D)>7 S X=X_"@"_$E($P(D,".",2)_"000",1,4)
  1.  Q X
  1.  ;
  1. READRVD(DATE) ;EP; returns a readable date from a FM reverse date
  1.  NEW Y S Y=9999999.9999-DATE D DD^%DT
  1.  Q Y
  1.  ;
  1. BROWSE() ;EP; -- calls DIR to ask if want to browse or print
  1.  Q $$READ("SO^B:BROWSE ON SCREEN;P:PRINT ON PAPER","PRINT MODE","BROWSE")
  1.  ;
  1. RANGE(DATE1,DATE2) ;EP; -- returns printable date range
  1.  Q $$FMTE^XLFDT(DATE1)_" to "_$$FMTE^XLFDT(DATE2)
  1.  ;
  1. INIT ;EP; initialize report header variables
  1.  S BDGUSR=$$GET1^DIQ(200,DUZ,1)       ;user's initials
  1.  S BDGFAC=$$GET1^DIQ(4,DUZ(2),.01)       ;facility name
  1.  S BDGTIME=$$TIME^BDGF($$NOW^XLFDT)   ;print time
  1.  S BDGDATE=$$FMTE^XLFDT(DT)           ;print date
  1.  Q
  1.  ;
  1. PRTKL ;EP; kill report header variables
  1.  K BDGUSR,BDGFAC,BDGTIME,BDGDATE Q
  1.  ;
  1. HELP(BDGHF,BDGN) ;EP; Called by various on-line help options
  1.  ;
  1.  ;This entry point gives the user a choice to display a help frame
  1.  ;or print it to a printer.  The entry point brings in the
  1.  ;parameter BDGHF which is the name of the help frame for the
  1.  ;option calling this routine.  The parameter BDGN is the number
  1.  ;of pages it takes if you print the help frame.
  1.  ;
  1.  D ^XBCLS,MSG($$SP(20)_"PIMS ON-LINE HELP UTILITY",2,2)
  1.  NEW BDGA,Y
  1.  S BDGA(1)="   How do you want me to present this help?"
  1.  S BDGA(2)=" "
  1.  S BDGA(3)="     1.  DISPLAY help to your screen"
  1.  S BDGA(4)="     2.  PRINT help to your printer ("_BDGN_" pages)"
  1.  S BDGA(5)=" "
  1.  S Y=$$READ("NO^1:2","   Choose One","","","",.BDGA)
  1.  ;
  1.  I Y=1 S XQH=BDGHF D EN^XQH Q
  1.  ;
  1.  I Y=2 S XQHFY=BDGHF,XQFMT="R" D ACTION^XQH4 Q
  1.  Q
  1.  ;
  1. SETPT(DFN) ;EP; -- sets AUPN variables when DFN is set
  1.  NEW X,DIC,Y S X="`"_DFN,DIC=2,DIC(0)="" D ^DIC Q
  1.  ;
  1. KILLVAR ;EP; -- kills patient variables  
  1.  D KVA^VADPT,KILL^AUPNPAT Q
  1.  ;
  1. CONF() ;EP; -- returns confidential warning
  1.  Q "Confidential Patient Data Covered by Privacy Act"
  1.  ;
  1. PAD(D,L) ;EP -- SUBRTN to pad length of data
  1.  ; -- D=data L=length
  1.  Q $E(D_$$REPEAT^XLFSTR(" ",L),1,L)
  1.  ;
  1. SP(N) ;EP -- SUBRTN to pad N number of spaces
  1.  Q $$PAD(" ",N)