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

BDGCRB1.m

Go to the documentation of this file. 
  1. BDGCRB1 ; IHS/ANMC/LJF - A SHEET PRINT ;  [ 01/05/2005  10:25 AM ]
  1.  ;;5.3;PIMS;**1001,1004,1008,1009**;MAY 28, 2004
  1.  ;IHS/ITSC/WAR 12/23/2004 PATCH 1001 removed line feed at top
  1.  ;             07/06/2004 PATCH 1001 at admission, put printed lines back in
  1.  ;IHS/OIT/LJF  09/02/2005 PATCH 1004 changed e-code line to match PCC change
  1.  ;cmi/anch/maw 12/07/2007 PATCH 1008 code set versioning ECLINE
  1.  ;cmi/anch/maw 02/22/2008 PATCH 1009 requirement 70 mod at DXLINE
  1.  ;
  1. EN ;EP; entry point from queuing
  1.  ; Assumes DFN, DGPMCA, and BDGFRM are set
  1.  ; BDGHALF may be set; if =1 prints bottom half of sheet-form only
  1.  ;                     if =2, prints data too
  1.  ; Do NOT set BDGA which is reserved as array in ADT ITEMS table
  1.  ; DO NOT use the following in these routines as they are used to
  1.  ;   loop through a sheets by date: BDGDT,BDGADT,BDGPAT,BDGDA
  1.  ;
  1.  U IO
  1.  ;F BDGCNT=1:1:BDGCOP D PRINT  ;cmi/maw 10/3/2007 handled in ZIS^BDGF
  1.  D PRINT  ;cmi/maw 10/3/2007
  1.  I BDGFIN>1 D ^BDGCPT                ;cpt listings
  1.  ;I '$D(BDGDT) D ^%ZISC               ;don't close if looping by date  cmi/maw 10/3/2007
  1.  ;I '$D(BDGDT) K BDGCNT,BDGHALF,BDGFIN,BDGCOP,BDGFRM  cmi/maw 10/3/2007 orig line
  1.  I $D(BDGDT) W @IOF  ;cmi/maw 4/15/2007 is this where the extra form feed is?
  1.  Q
  1.  ;
  1. PRINT ; print this copy
  1.  NEW BDGVST,X,LINE,LN
  1.  ;I BDGCNT>1 W @IOF  ;cmi/maw 10/3/2007 org line
  1.  I $G(BDGCOP)>1 W @IOF  ;cmi/maw 10/3/2007 for mult copies
  1.  ;
  1.  ; title of a sheet
  1.  S X=$$GET1^DIQ(9009016.8,BDGFRM,.03)  ;inpt title from file
  1.  I $$LASTSRVN^BDGF1(DGPMCA,DFN)["OBSERVATION" S X="OBSERVATION COVERSHEET"
  1.  ;W !,X," **",$$CONF^BDGF,"**"  ;IHS/ITSC/WAR 12/23/2004 P #1001 nextLn
  1.  W X," **",$$CONF^BDGF,"**"
  1.  ;
  1.  I '$D(DGPMDA) S DGPMDA=DGPMCA               ;set curr movmnt if not set
  1.  S BDGVST=$$GET1^DIQ(405,DGPMCA,.27,"I")     ;set visit ien
  1.  ;
  1.  ; loop through form line in display order
  1.  S LINE=0 F  S LINE=$O(^BDGFRM(BDGFRM,"LINE","ALN",LINE)) Q:'LINE  D
  1.  . S LN=0 F  S LN=$O(^BDGFRM(BDGFRM,"LINE","ALN",LINE,LN)) Q:'LN  D
  1.  .. ;
  1.  .. ; if beginning of bottom half, want to continue?
  1.  .. I $P(^BDGFRM(BDGFRM,"LINE",LN,0),U,5)=1,$G(BDGHALF)=0 Q
  1.  .. ;
  1.  .. ; does line need dashed line before it?
  1.  .. I $P($G(^BDGFRM(BDGFRM,"LINE",LN,0)),U,3)=1 D
  1.  ... W !,$$REPEAT^XLFSTR("-",80)
  1.  .. ;
  1.  .. D LOOP("HDR")             ;loop thru items and print headers
  1.  .. ;
  1.  .. ;no data if just printing bottom half of form, just blank lines
  1.  .. I $P(^BDGFRM(BDGFRM,"LINE",LN,0),U,5),$G(BDGHALF)=1 D  Q
  1.  ...;IHS/ITSC/WAR 7/26/2004 PATCH #1001 put printed lines back in
  1.  ...; S X=$P(^BDGFRM(BDGFRM,"LINE",LN,0),U,6) S:'X X=1 F I=1:1:X W !
  1.  ... S X=$P(^BDGFRM(BDGFRM,"LINE",LN,0),U,6) S:'X X=1 F I=1:1:X D
  1.  .... W !,I,"_______   _________________________________"
  1.  .... W "____________________________________",!
  1.  .. ;
  1.  .. D LOOP("DATA")            ;loop thru items and print data
  1.  ;
  1.  Q:BDGFIN=1    ;a sheet only
  1.  ;
  1.  Q
  1.  ;
  1. LOOP(TYPE) ; loop thru items in display order & print
  1.  ; If TYPE="HDR" headers will print, else DATA will print
  1.  ;
  1.  I TYPE="HDR" Q:$P(^BDGFRM(BDGFRM,"LINE",LN,0),U,4)=1  ;skip header line
  1.  ;
  1.  NEW ORD,ITEM,NODE,LEN,HDR,DATA
  1.  S ORD=0 W !
  1.  F  S ORD=$O(^BDGFRM(BDGFRM,"LINE",LN,"ITEM","AITM",ORD)) Q:'ORD  D
  1.  . S ITEM=0
  1.  . F  S ITEM=$O(^BDGFRM(BDGFRM,"LINE",LN,"ITEM","AITM",ORD,ITEM)) Q:'ITEM  D
  1.  .. S NODE=^BDGFRM(BDGFRM,"LINE",LN,"ITEM",ITEM,0),LEN=$P(NODE,U,4)
  1.  .. ;
  1.  .. I TYPE="HDR" D  Q
  1.  ... S HDR=$P(NODE,U,3) W $$PAD(HDR,LEN)  ;W:($X<79) "  "
  1.  .. ;
  1.  .. S DATA=$$GET1^DIQ(9009016.9,+NODE,1) Q:DATA=""
  1.  .. K BDGA S Y="" X DATA
  1.  .. I '$D(BDGA) W $$PAD(Y,LEN) Q                  ;single line data
  1.  .. S I=0 F  S I=$O(BDGA(I)) Q:'I  W BDGA(I),!    ;multi line data
  1.  Q
  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) ; -- SUBRTN to pad N number of spaces
  1.  Q $$PAD(" ",N)
  1.  ;
  1.  ;
  1. DXLINE(VISIT) ;EP; called by diagnosis code ADT ITEM
  1.  ; returns lines of ICD code, hosp acq and provider narrative
  1.  ; returns BDGA array
  1.  Q:'VISIT  K BDGA
  1.  NEW N,LINE,NARR,COUNT,X
  1.  S N=0 F  S N=$O(^AUPNVPOV("AD",VISIT,N)) Q:'N  D
  1.  . S LINE=$$PAD(" "_$$GET1^DIQ(9000010.07,N,.01),16)       ;icd code
  1.  . ;S X=$$GET1^DIQ(9000010.07,N,.07,"I")                   ;cause of dx cmi/maw 2/28/2008 orig line
  1.  . S X=$$GET1^DIQ(9000010.07,N,.22,"I")                    ;POA cmi/maw 2/22/2008 PATCH 1009 requirement 70
  1.  . ;S LINE=LINE_$S(X=1:"X",1:"")                           ;cmi/maw 2/22/2008 PATCH 1009 requirement 70 orig line
  1.  . S LINE=LINE_$S(X="Y":"X",1:"")                          ;cmi/maw 2/22/2008 PATCH 1009 requirement 70 print X if present on admission
  1.  . S NARR=$$GET1^DIQ(9000010.07,N,.04) D WRAP(NARR,27,80)
  1.  . S LINE=$$PAD(LINE,27)_$G(^UTILITY($J,"W",27,1,0))       ;1st line narrO
  1.  . S COUNT=$G(COUNT)+1,BDGA(COUNT)=LINE
  1.  . ;
  1.  . ; if any more provider narrative, add more lines
  1.  . S X=1 F  S X=$O(^UTILITY($J,"W",27,X)) Q:'X  D
  1.  .. S COUNT=$G(COUNT)+1,BDGA(COUNT)=$$SP(27)_^UTILITY($J,"W",27,X,0)
  1.  Q
  1.  ;
  1. ECLINE(VISIT) ;EP; called by e-code line ADT ITEM
  1.  ; returns lines of injury date, cause & e-code, place and code
  1.  ; returns BDGA array
  1.  Q:'VISIT  K BDGA
  1.  NEW N,LINE,NARR,COUNT,X
  1.  S N=0 F  S N=$O(^AUPNVPOV("AD",VISIT,N)) Q:'N  D
  1.  . S LINE=$$SP(3)_$$GET1^DIQ(9000010.07,N,.13)                  ;injury date
  1.  . S X=$$GET1^DIQ(9000010.07,N,.09,"I") Q:X=""                  ;E-code ien
  1.  . ;S LINE=$$PAD(LINE,19)_$$GET1^DIQ(80,+X,3)                   ;icd narr
  1.  . S LINE=$$PAD(LINE,19)_$P($$ICDDX^ICDCODE(+X),U,4)            ;icd narr
  1.  . S LINE=$$PAD(LINE,42)_$$SP(2)_$$GET1^DIQ(9000010.07,N,.09)   ;ecode
  1.  . ;
  1.  . ;IHS/OIT/LJF 9/2/2005 PATCH 1004 PCC now asks for ecode-2 and ecode for place
  1.  . ;S LINE=$$PAD(LINE,52)_$E($$GET1^DIQ(9000010.07,N,.11),1,19) ;place
  1.  . ;S LINE=$$PAD(LINE,73)_$$GET1^DIQ(9000010.07,N,.11,"I")      ;place code
  1.  . I '$$PATCH^XPDUTL("APCD*2.0*8") D
  1.  . . S LINE=$$PAD(LINE,52)_$E($$GET1^DIQ(9000010.07,N,.11),1,19) ;place
  1.  . . S LINE=$$PAD(LINE,73)_$$GET1^DIQ(9000010.07,N,.11,"I")      ;place code
  1.  . E  D
  1.  . S LINE=$$PAD(LINE,55)_$$GET1^DIQ(9000010.07,N,.18)           ;e-code 2
  1.  . S LINE=$$PAD(LINE,72)_$$GET1^DIQ(9000010.07,N,.21)           ;place code
  1.  . ;end of PATCH 1004 changes
  1.  . ;
  1.  . S COUNT=$G(COUNT)+1,BDGA(COUNT)=LINE
  1.  Q
  1.  ;
  1. PRCLINE1(VISIT) ;EP; called by procedure code ADT ITEM
  1.  ; returns lines of ICD code, DX, narative, infection, op date, prv code
  1.  ; returns BDGA array
  1.  Q:'VISIT  K BDGA
  1.  NEW N,LINE,NARR,COUNT,X
  1.  S N=0 F  S N=$O(^AUPNVPRC("AD",VISIT,N)) Q:'N  D
  1.  . S LINE=$$PAD($J($$GET1^DIQ(9000010.08,N,.01),7),11)             ;icd code
  1.  . S LINE=LINE_$$GET1^DIQ(9000010.08,N,.05)                        ;dx code
  1.  . S NARR=$$GET1^DIQ(9000010.08,N,.04) D WRAP(NARR,22,58)
  1.  . S LINE=$$PAD(LINE,21)_$G(^UTILITY($J,"W",22,1,0))               ;1st line narrO
  1.  . S LINE=$$PAD(LINE,60)_$$GET1^DIQ(9000010.08,N,.08,"I")          ;infection?
  1.  . S LINE=$$PAD(LINE,65)_$E($$GET1^DIQ(9000010.08,N,.06,"I"),4,7)  ;date
  1.  . S LINE=$$PAD(LINE,72)_$$PRVCODE(N)
  1.  . S COUNT=$G(COUNT)+1,BDGA(COUNT)=LINE
  1.  . ;
  1.  . ; if any more provider narrative, add more lines
  1.  . S X=1 F  S X=$O(^UTILITY($J,"W",22,X)) Q:'X  D
  1.  .. S COUNT=$G(COUNT)+1,BDGA(COUNT)=$$SP(21)_^UTILITY($J,"W",22,X,0)
  1.  Q
  1.  ;
  1. PRCLINE2(VISIT) ;EP; called by procedure code ADT ITEM
  1.  ; returns lines of ICD code, CPT, DX, narrative, op date, prv code
  1.  ; returns BDGA array
  1.  Q:'VISIT  K BDGA
  1.  NEW N,LINE,NARR,COUNT,X
  1.  S N=0 F  S N=$O(^AUPNVPRC("AD",VISIT,N)) Q:'N  D
  1.  . S LINE=$$PAD($J($$GET1^DIQ(9000010.08,N,.01),7),9)              ;icd code
  1.  . S LINE=LINE_$$GET1^DIQ(9000010.08,N,.16)                        ;cpt code
  1.  . S LINE=LINE_$$GET1^DIQ(9000010.08,N,.17)                        ;cpt modifier
  1.  . S LINE=$$PAD(LINE,17)_$$GET1^DIQ(9000010.08,N,.05)              ;dx code
  1.  . S NARR=$$GET1^DIQ(9000010.08,N,.04) D WRAP(NARR,28,58)
  1.  . S LINE=$$PAD(LINE,24)_$G(^UTILITY($J,"W",28,1,0))               ;1st line narrO
  1.  . S LINE=$$PAD(LINE,62)_$E($$GET1^DIQ(9000010.08,N,.06,"I"),4,7)  ;date
  1.  . S LINE=$$PAD(LINE,70)_$$PRVCODE(N)
  1.  . S COUNT=$G(COUNT)+1,BDGA(COUNT)=LINE
  1.  . ;
  1.  . ; if any more provider narrative, add more lines
  1.  . S X=1 F  S X=$O(^UTILITY($J,"W",28,X)) Q:'X  D
  1.  .. S COUNT=$G(COUNT)+1,BDGA(COUNT)=$$SP(24)_^UTILITY($J,"W",28,X,0)
  1.  . ;
  1.  . ; if elasped anesthesia time entered, display it
  1.  . S X=$$GET1^DIQ(9000010.08,N,.13) I X]"" D
  1.  .. S COUNT=$G(COUNT)+1,BDGA(COUNT)=$$SP(26)_"anesthesia time (min): "_X
  1.  ;
  1.  K ^UTILITY($J,"W")
  1.  Q
  1.  ;
  1. WRAP(X,DIWL,DIWR) ; -- print text fields in word-wrap mode
  1.  K ^UTILITY($J,"W") S DIWF="" D ^DIWP
  1.  Q
  1.  ;
  1. PRVCODE(IEN) ; return provider code for procedure ien
  1.  NEW Y,FILE
  1.  S Y=$$GET1^DIQ(9000010.08,IEN,.11,"I")
  1.  S FILE=$S($P(^DD(9000010.08,.11,0),U,2)["200":200,1:6)
  1.  Q $$GET1^DIQ(FILE,+Y,9999999.09)