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

DGPWB.m

Go to the documentation of this file. 
  1. DGPWB ;ALB/CAW/MLR - Patient Wristband Print ; 9/27/00 3:40pm
  1.  ;;5.3;Registration;**62,82,287,1004,1009,1015**;Aug 13, 1993;Build 21
  1.  ;  -**287** Substituting SS# when Primary long ID missing in .36
  1.  ;IHS/OIT/LJF 08/31/2005 PATCH 1004 use chart # instead of SSN for patient ID
  1.  ;cmi/anch/maw 02/18/2008 PATCH 1009 requirement 3 in SET
  1.  ;
  1. EN ; Ask patient name
  1.  ; This is used when printing a wristband from the menu
  1.  ;
  1.  N DFN,VAIN,VAERR,DIC,Y,OPTIND
  1.  S OPTIND=0
  1.  S DIC(0)="AEMQZ",DIC="^DPT("
  1.  D ^DIC I $D(DTOUT)!$D(DUOUT)!(Y<0) G ENQ
  1.  S DFN=+Y D INP^VADPT
  1.  S:'$G(VAIN(4)) OPTIND=1
  1.  I $G(VAIN(4)),('$$DIVISION($P(VAIN(4),U))) W !,"Printing Wristbands for inpatients at this division is set to no." G ENQ
  1.  I OPTIND S Y=$$DEVICE() G:'Y!(Y>1) ENQ D SET G ENQ
  1.  D START(DFN)
  1. ENQ K DTOUT,DUOUT Q
  1.  ;
  1. START(DFN) ;Start
  1.  ; This is where it will be used when in admit or transfer
  1.  ;  Input is patient IFN
  1.  ;
  1.  N WARD,DIVISION,PRINT,Y
  1.  D INP^VADPT I '$G(VAIN(4)) G STARTQ
  1.  S WARD=+VAIN(4)
  1. TRANS I $G(DGPMA),'$$TRCHK($P(DGPMA,U,18)) G STARTQ
  1.  ; Check to see if no change was made on edit
  1.  I $D(DGPMA),$D(DGPMP),$P(DGPMA,U,18)=41 N Y D  G DIV:Y
  1.  .S Y=$O(^UTILITY("DGPM",$J,2,"")) Q:'Y
  1.  .I $P(^UTILITY("DGPM",$J,2,Y,"P"),U,6)=$P(^UTILITY("DGPM",$J,2,Y,"A"),U,6) S Y=0
  1.  I $D(DGPMA),$D(DGPMP),($P(DGPMA,U,6)=$P(DGPMP,U,6)) G STARTQ
  1.  ; Check to see if division parameter to print wristband is on
  1. DIV I '$$DIVISION(WARD) G STARTQ
  1.  I $G(DGPMA),'$$ASK G STARTQ
  1.  ; Prompt for device - quit if device is not selected or is queued
  1.  S Y=$$DEVICE() I 'Y!(Y>1) G STARTQ
  1.  ; Set up lines to print
  1.  D SET
  1. STARTQ Q
  1.  ;
  1. DIVISION(WARD) ; Obtain Divison from Ward Location
  1.  ;
  1.  N Y,DIVISION
  1.  S Y=0
  1.  ; Print Patient Wristband parameter
  1.  S DIVISION=$P($G(^DIC(42,+WARD,0)),U,11)
  1.  I '$P(^DG(43,1,"GL"),U,2) S DIVISION=$O(^DG(40.8,0))
  1.  I $P($G(^DG(40.8,+DIVISION,0)),U,8)="Y" S Y=1
  1.  Q Y
  1.  ;
  1. SET ;Set the lines to print
  1.  ;This is where taskman will start when job is queued.
  1.  ;  Input needed is DFN and WARD (WARD is set to IFN of WARD LOCATION)
  1.  ;
  1.  N CNT,BAND,DATA,FINAL,IFN,ITEMD,LINE,X,WHERE
  1.  D DEM^VADPT
  1.  ;
  1.  ; If a different wristband is going to be used-change name in "B" x-ref
  1.  ;
  1.  ;S LINE=0 S IFN=$O(^DIC(39.1,"B","WRISTBAND",0)) Q:'IFN  ;cmi/maw 2/18/2008 PATCH 1009
  1.  S LINE=0 S IFN=$O(^DIC(39.1,"B","IHS WRISTBAND",0)) Q:'IFN  ;cmi/maw 2/18/2008 PATCH 1009 requirement 3
  1.  F  S LINE=$O(^DIC(39.1,IFN,1,LINE)) Q:'LINE  D
  1.  .S DATA=0 F  S DATA=$O(^DIC(39.1,IFN,1,LINE,1,DATA)) Q:'DATA  D
  1.  ..S ITEMD=^DIC(39.1,IFN,1,LINE,1,DATA,0)
  1.  ..S X=$G(^DIC(39.2,+ITEMD,1)) X X
  1.  ..;
  1.  ..;Checking for PID# and substituting SS# if missing **287**
  1.  ..I Y="",$G(^DIC(39.2,+ITEMD,0))="PID" D PID
  1.  ..;
  1.  ..S BAND(LINE,-DATA)=$E(Y,1,$P(ITEMD,U,3))_"^"_$P(ITEMD,U,2)
  1.  .S WHERE="" F  S WHERE=$O(BAND(LINE,WHERE)) Q:'WHERE  D
  1.  ..I $D(BAND(LINE,(WHERE+1))) S $P(BAND(LINE,WHERE),U,2)=($P(BAND(LINE,WHERE),U,2))-($L($P(BAND(LINE,(WHERE+1)),U)))
  1.  ..S $P(FINAL(LINE)," ",$P(BAND(LINE,WHERE),U,2))=$P(BAND(LINE,WHERE),U)
  1.  F CNT=1:1:99 Q:'$D(FINAL(CNT))  S X="LINE"_CNT S @X=FINAL(CNT)
  1.  D PRINT
  1.  D:'$D(ZTQUEUED) ^%ZISC
  1.  ; This is where the call to update the allergy file
  1.  S X="GMRAMCU0" X ^%ZOSF("TEST") I $T D IDBAND^GMRAMCU0(DFN,DT,DUZ)
  1.  D END
  1.  Q
  1.  ;
  1. PID ;Substituting SS# for missing PID#  **287**  MLR
  1.  ;
  1.  S Y=$S($G(VA("PID"))]"":"#"_VA("PID"),1:"NO ID FOUND") Q   ;IHS/OIT/LJF 8/31/2005 PATCH 1004
  1.  ;
  1.  S Y=$P($G(^DPT(DFN,0)),U,9)
  1.  D
  1.  . I Y S Y=$E(Y,1,3)_" "_$E(Y,4,5)_" "_$E(Y,6,$L(Y)) Q
  1.  . S Y="NO ID FOUND" Q
  1.  Q  ;PID
  1.  ;
  1. END ;Clean up variables
  1.  K VARIABLE
  1.  N CNT,VAR
  1.  F CNT=1:1:99 S VAR="LINE"_CNT Q:'$D(@VAR)  K @VAR
  1.  Q
  1.  ;
  1. PRINT ; Print the wristband
  1.  ;
  1.  ; Change call from BL to whatever device is added in DGPWBD
  1.  ;
  1.  D BL^DGPWBD
  1.  Q
  1.  ;
  1. DEVICE() ;
  1.  S Y=0
  1. DEVEN S %ZIS="Q",%ZIS("A")="PRINT WRISTBAND ON DEVICE: ",%ZIS("B")=""
  1.  D ^%ZIS I POP G DEVICEQ
  1.  I $E(IOST,1,2)'["P-" W !,"A printer must be selected." G DEVEN
  1.  I '$D(IO("Q")) S Y=1 G DEVICEQ
  1.  S Y=$$QUE
  1. DEVICEQ Q Y
  1.  ;
  1. QUE() ; -- que job
  1.  ; return: did job que [ 1|yes   0|no ]
  1.  ;
  1.  K ZTSK,IO("Q")
  1.  S ZTDESC="Patient Wristband Print",ZTRTN="SET^DGPWB"
  1.  F X="WARD","DFN" S ZTSAVE(X)=""
  1.  D ^%ZTLOAD W:$D(ZTSK) "   (Task: ",ZTSK,")"
  1.  Q $D(ZTSK)
  1.  ;
  1. TRCHK(TYPE) ;Check to see if appropriate type to continue
  1.  ;
  1.  N MVMT,Y
  1.  S Y=0
  1.  S MVMT=$P($G(^DG(405.2,+TYPE,0)),U,2) I MVMT=1 S Y=1 G TRCHKQ
  1.  I "^4^13^14^22^23^24^41^44^45^"[(U_TYPE_U) S Y=1
  1. TRCHKQ Q Y
  1.  ;
  1. ASK() ;Ask if they want to print
  1.  W ! S DIR("A")="Do you want to print a Patient Wristband"
  1.  S DIR(0)="Y",DIR("B")="YES"
  1.  D ^DIR K DIR I $D(DUOUT)!($D(DTOUT)) S Y=0
  1. ASKQ Q Y