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