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

DGQESC5.m

Go to the documentation of this file. 
  1. DGQESC5 ;ALB/JFP - ID Card - standalone;01/09/96
  1.  ;;5.3;REGISTRATION;**73,1015**;DEC 11,1996;Build 21
  1.  ;;Per VHA Directive 10-93-142, this routine should not be modified.
  1.  ;
  1. VIC ; -- Ask if user wants to download demographic data to photo capture
  1.  ;    station. Checks MAS paramter file.  Called from DGREG00, DG10,
  1.  ;    and DG1010P.
  1.  ;S Y=$P(^DG(43,1,0),U,28) Q:'Y
  1.  W !,"Download VIC data" S %=2 D YN^DICN I %=-1!(%=2) Q
  1.  I %=0 W !,"  Enter YES to download patient demographic data to photo capture station" G VIC
  1.  I %=1 D EN
  1.  Q
  1.  ;
  1. MAN ; -- Entry point for manual card
  1.  F  S DIC="^DPT(",DIC(0)="AEQMZ" W ! D ^DIC Q:($D(DTOUT)!(Y'>0))  S DFN=+Y D EN
  1.  K DFN,DGPT,DIC,X,Y
  1.  Q
  1.  ;
  1. EN ; -- Main entry point for VIC download
  1.  ; -- Checks for valid DFN
  1.  S L=0 I $S('$D(DFN):1,'$D(^DPT(+DFN,0)):1,1:0) G EXIT
  1.  ; -- Set Variables for VIC card
  1.  ;S S=4 ; VIC card entry in embosser file 39.1
  1.  ; -- Ensure uppercase
  1.  S X=$P(^DPT(DFN,0),"^",1)
  1.  I X?.E1L.E D FUNC S DIE=2,DA=DFN,DR=".01///"_X D ^DIE
  1. CKADD ; -- Checks address
  1.  I $D(^DPT(DFN,.11)) S X=$P(^DPT(DFN,.11),"^",1) I X["#" D ADD G CKADD
  1.  I X?.E1L.E D FUNC S DIE=2,DA=DFN,DR=".111///"_X D ^DIE
  1.  I $D(^DPT(DFN,.11)) S X=$P(^DPT(DFN,.11),"^",4) I X?.E1L.E D FUNC S DIE=2,DA=DFN,DR=".114///"_X D ^DIE
  1.  ; -- Check Embosser file for entry
  1.  ;S S=$O(^DIC(39.1,"C",S,"")) I $S('S:1,'$D(^DIC(39.1,S,0)):1,'$P(^(0),"^",6):1,1:0) W !,"Embosser files not correctly set up...contact your site manager" G EXIT
  1.  ; -- checks for required data elements
  1.  D ERROR
  1.  I $D(DGE) D OK I 'DGFL G EXIT
  1. DOWN ; -- Call routine to download information via HL7 to photo capture stat
  1.  S RESULTS=$$EVENT^DGQEHL71("A08",DFN)
  1.  I $P(RESULTS,"^",1)=-1 W !,"Data not downloaded.  Error - ",$P(RESULTS,"^",2)
  1.  W:$P(RESULTS,"^",1)'=-1 !,"Data Download successfully to VIC"
  1.  ;
  1. EXIT K %,S,X,Y,L,DA,DGE,DGFL,DIE,DR,I,RESULTS
  1.  Q
  1.  ;
  1. FUNC ; -- Convert characters from lower case to uppercase
  1.  S I=$O(^DD("FUNC","B","UPPERCASE",0)) X:$D(^DD("FUNC",+I,1)) ^DD("FUNC",I,1)
  1.  Q
  1.  ;
  1. ADD ; -- Strips # characters, updates field
  1.  S I=$F(X,"#") S X1=$E(X,1,I-2) S X=X1_" "_$E(X,I,99) S DIE=2,DA=DFN,DR=".111///"_X D ^DIE
  1.  K X1 Q
  1.  ;
  1. OK ; -- Ask if ok to download data, if data missing
  1.  S DGFL=0 N S W !,"Do you still wish to download data " S %=2 D YN^DICN
  1.  I %=0 W !?3,"Enter 'Y'es to download data, otherwise, 'N'o." G OK
  1.  I %=1 S DGFL=1
  1.  Q
  1.  ;
  1. ERROR ;Error messages for incomplete data
  1.  I $S('$D(^DPT(DFN,.36)):1,'^(.36):1,1:0) S DGE=1 S Y="ELIGIBILITY CODE" D ERR
  1.  I $D(^DPT(DFN,"VET")),(^DPT(DFN,"VET")="N") G NONVET
  1.  I $S('$D(^DPT(DFN,.32)):1,'$P(^(.32),"^",3):1,1:0) S Y="PERIOD OF SERVICE" D ERR
  1.  I $S('$D(^DPT(DFN,.31)):1,$P(^(.31),"^",3)']"":1,1:0) S Y="CLAIM NUMBER" D ERR
  1. NONVET S X=^DPT(DFN,0) F I=1,2,3,5,8,9 I $P(X,"^",I)="" S Y=$P(^DD(2,".0"_I,0),"^",1) D ERR
  1.  I $D(^DPT(DFN,.11)) S X=^DPT(DFN,.11) F I=1,4,5,6,7 I $P(X,"^",I)="" S Y=$P(^DD(2,".11"_I,0),"^",1) D ERR
  1.  I '$D(^DPT(DFN,.11)) S DGE=1 S Y="ADDRESS DATA" D ERR Q
  1.  Q
  1.  ;
  1. ERR W !," - ",Y," MISSING" S DGE=1 Q
  1. END ; -- End of code
  1.  Q
  1.  ;