DGQEMA ;RWA/SLC-DHW/OKC-ALB/MIR - EMBOSSER AUTO QUEUE;03/21/85 2:31 PM ; 04 Oct 85 10:24 AM
;;5.3;Registration;**73,191,1015**;Aug 13, 1993;Build 21
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
;INPUT: DFN - patient (NOT killed on exit unless manuel q)
;
;USED: DGHD - HOLD? (1 for yes, 2 for no, 0 for ask)
; DGQUAN - how many cards?
; S - type of card (1 for NSC, 2 for SC, 3 for NON-VET,
; and 9 for FREE TEXT)
; DGFL - 1 if '^', 2 for time-out, otherwise 0
; DGLINE - Lines of text subscripted by line #
; DGE - errors? Yes if $D(DGE)
;
EN S L=0 I $S('$D(DFN):1,'$D(^DPT(+DFN,0)):1,1:0) G END
S X=$P(^DPT(DFN,0),"^",1) I X?.E1L.E D FUNC S DIE=2,DA=DFN,DR=".01///"_X D ^DIE
CKADD 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
S:'$D(DGHD) DGHD=0
I $D(^DPT(DFN,"VET")),(^DPT(DFN,"VET")="N") S S=3 G CONT
I '$D(^DPT(DFN,.3)) D MSG G END
S X=$P(^DPT(DFN,.3),"^",1)
S V="" I $D(^DPT(DFN,.361)) S V=$P(^DPT(DFN,.361),"^",1)
S S=$S(X?1"Y"&(V?1"V"):2,X?1"Y"&(V'?1"V"):1,X?1"N":1,1:"") I S="" G END
I X?1"Y"&(V'?1"V") W !,"Service connected eligibility NOT verified",!,"Card will be queued as Non service connected (blue)",!
;
CONT 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 END
S DGX=^DIC(39.1,S,0),S=$P(DGX,"^",6)
D ERROR^DGQEMA1 ;check that data elements are complete
I $D(DGE) D OK I 'DGFL G END
S:'$D(DGQUAN) DGQUAN=$P(DGX,"^",4) S:'DGQUAN DGQUAN=1
F K=1:1:7 S DGLINE(K)="" F DGI=0:0 S DGI=$O(^DIC(39.1,S,1,K,1,DGI)) Q:'DGI I $D(^(DGI,0)) S DGJ=^(0) D DATA
F K=8,9 D FT^DGQEMA1 I DGFL Q
I DGFL=2 W !,*7,"Data card NOT queued" G END
S DGTYP=S D ^DGQEMA1 ;hold or print
;
END K %,%Y,D,S,X,Y,L,AMT,DA,DGA,DGBLK,DGE,DGFL,DGHD,DGHOL,DGI,DGJ,DGLINE,DGQUAN,DGTYP,DGX,DIC,DIE,DR,DTOUT,I,K,V,Z
K ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
Q
;
FUNC S I=$O(^DD("FUNC","B","UPPERCASE",0)) X:$D(^DD("FUNC",+I,1)) ^DD("FUNC",I,1)
Q
;
ADD 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
;
DATA ;get lines 1-7 for data card per file 39.2
;DGJ=ptr to xecutable code^start position^length
Q:'$D(^DIC(39.2,+DGJ,1)) X ^(1)
K DGBLK S $P(DGBLK," ",80)=""
S DGLINE(K)=$E(DGLINE(K)_DGBLK,1,$P(DGJ,"^",2)-1)_$E(Y_DGBLK,1,$P(DGJ,"^",3))
Q
;
;
MAN ;manuel Q
F DGPT=1:1:10 S DIC="^DPT(",DIC(0)="AEQMZ" W ! D ^DIC Q:Y'>0 S DFN=+Y D NUM Q:DGMANFL=2 I 'DGMANFL D EN
K DFN,DGMANFL,DGPT,DIC,X,Y Q
;
NUM ;how many cards...set DGQUAN
S DGMANFL=0 R !,"Number of cards to print (1-8): 1//",X:DTIME I '$T S DGMANFL=2 Q
I X["^" S DGMANFL=1 Q
I X="" S X=1 W X
I X'>0!(X'<9) W !?3,"Enter the number of cards you wish to print (1-8)" G NUM
S DGQUAN=X
Q
;
;
MSG ;print error message if card can't be printed
W !,"Service connected or NSC status not entered...cannot print card"
Q
;
;
OK ;ask if ok to print data cards if data missing
S DGFL=0 N S W !,"Do you still wish to emboss a patient data card" S %=2 D YN^DICN
I %=0 W !?3,"Enter 'Y'es to emboss a card, otherwise, 'N'o." G OK
I %=1 S DGFL=1
Q
;
;
EMBOS ; -- Ask if user wants to emboss (OLD) data card, downloads data to VIC.
; Called from DGREG00, DG10, and DG1010P
; -- Download VIC Data
D VIC^DGQESC5
Q ;Do not do old card anymore patch 191
OLD ; -- Creates old card, if flag set in MAS parameter file
S Y=$P(^DG(43,1,0),U,28) Q:'Y W !,"EMBOSS (OLD) DATA CARD" S %=2 D YN^DICN I %=-1!(%=2) Q
I %=0 W !," Enter YES to print patient data card for this patient, otherwise respond NO" G OLD
I %=1 D EN
Q
;
DGQEMA ;RWA/SLC-DHW/OKC-ALB/MIR - EMBOSSER AUTO QUEUE;03/21/85 2:31 PM ; 04 Oct 85 10:24 AM
+1 ;;5.3;Registration;**73,191,1015**;Aug 13, 1993;Build 21
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
+4 ;INPUT: DFN - patient (NOT killed on exit unless manuel q)
+5 ;
+6 ;USED: DGHD - HOLD? (1 for yes, 2 for no, 0 for ask)
+7 ; DGQUAN - how many cards?
+8 ; S - type of card (1 for NSC, 2 for SC, 3 for NON-VET,
+9 ; and 9 for FREE TEXT)
+10 ; DGFL - 1 if '^', 2 for time-out, otherwise 0
+11 ; DGLINE - Lines of text subscripted by line #
+12 ; DGE - errors? Yes if $D(DGE)
+13 ;
EN SET L=0
IF $SELECT('$DATA">DATA(DFN):1,'$DATA">DATA(^DPT(+DFN,0)):1,1:0)
GOTO END
+1 SET X=$PIECE(^DPT(DFN,0),"^",1)
IF X?.E1L.E
DO FUNC
SET DIE=2
SET DA=DFN
SET DR=".01///"_X
DO ^DIE
CKADD IF $DATA(^DPT(DFN,.11))
SET X=$PIECE(^DPT(DFN,.11),"^",1)
IF X["#"
DO ADD
GOTO CKADD
+1 IF X?.E1L.E
DO FUNC
SET DIE=2
SET DA=DFN
SET DR=".111///"_X
DO ^DIE
+2 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
+3 IF '$DATA(DGHD)
SET DGHD=0
+4 IF $DATA(^DPT(DFN,"VET"))
IF (^DPT(DFN,"VET")="N")
SET S=3
GOTO CONT
+5 IF '$DATA(^DPT(DFN,.3))
DO MSG
GOTO END
+6 SET X=$PIECE(^DPT(DFN,.3),"^",1)
+7 SET V=""
IF $DATA(^DPT(DFN,.361))
SET V=$PIECE(^DPT(DFN,.361),"^",1)
+8 SET S=$SELECT(X?1"Y"&(V?1"V"):2,X?1"Y"&(V'?1"V"):1,X?1"N":1,1:"")
IF S=""
GOTO END
+9 IF X?1"Y"&(V'?1"V")
WRITE !,"Service connected eligibility NOT verified",!,"Card will be queued as Non service connected (blue)",!
+10 ;
CONT SET S=$ORDER(^DIC(39.1,"C",S,""))
IF $SELECT('S:1,'$DATA(^DIC(39.1,S,0)):1,'$PIECE(^(0),"^",6):1,1:0)
WRITE !,"Embosser files not correctly set up...contact your site manager"
GOTO END
+1 SET DGX=^DIC(39.1,S,0)
SET S=$PIECE(DGX,"^",6)
+2 ;check that data elements are complete
DO ERROR^DGQEMA1
+3 IF $DATA(DGE)
DO OK
IF 'DGFL
GOTO END
+4 IF '$DATA(DGQUAN)
SET DGQUAN=$PIECE(DGX,"^",4)
IF 'DGQUAN
SET DGQUAN=1
+5 FOR K=1:1:7
SET DGLINE(K)=""
FOR DGI=0:0
SET DGI=$ORDER(^DIC(39.1,S,1,K,1,DGI))
IF 'DGI
QUIT
IF $DATA(^(DGI,0))
SET DGJ=^(0)
DO DATA
+6 FOR K=8,9
DO FT^DGQEMA1
IF DGFL
QUIT
+7 IF DGFL=2
WRITE !,*7,"Data card NOT queued"
GOTO END
+8 ;hold or print
SET DGTYP=S
DO ^DGQEMA1
+9 ;
END KILL %,%Y,D,S,X,Y,L,AMT,DA,DGA,DGBLK,DGE,DGFL,DGHD,DGHOL,DGI,DGJ,DGLINE,DGQUAN,DGTYP,DGX,DIC,DIE,DR,DTOUT,I,K,V,Z
+1 KILL ZTDESC,ZTDTH,ZTIO,ZTRTN,ZTSAVE
+2 QUIT
+3 ;
FUNC SET I=$ORDER(^DD("FUNC","B","UPPERCASE",0))
IF $DATA(^DD("FUNC",+I,1))
XECUTE ^DD("FUNC",I,1)
+1 QUIT
+2 ;
ADD 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
+1 KILL X1
QUIT
+2 ;
DATA ;get lines 1-7 for data card per file 39.2
+1 ;DGJ=ptr to xecutable code^start position^length
+2 IF '$DATA(^DIC(39.2,+DGJ,1))
QUIT
XECUTE ^(1)
+3 KILL DGBLK
SET $PIECE(DGBLK," ",80)=""
+4 SET DGLINE(K)=$EXTRACT(DGLINE(K)_DGBLK,1,$PIECE(DGJ,"^",2)-1)_$EXTRACT(Y_DGBLK,1,$PIECE(DGJ,"^",3))
+5 QUIT
+6 ;
+7 ;
MAN ;manuel Q
+1 FOR DGPT=1:1:10
SET DIC="^DPT("
SET DIC(0)="AEQMZ"
WRITE !
DO ^DIC
IF Y'>0
QUIT
SET DFN=+Y
DO NUM
IF DGMANFL=2
QUIT
IF 'DGMANFL
DO EN
+2 KILL DFN,DGMANFL,DGPT,DIC,X,Y
QUIT
+3 ;
NUM ;how many cards...set DGQUAN
+1 SET DGMANFL=0
READ !,"Number of cards to print (1-8): 1//",X:DTIME
IF '$TEST
SET DGMANFL=2
QUIT
+2 IF X["^"
SET DGMANFL=1
QUIT
+3 IF X=""
SET X=1
WRITE X
+4 IF X'>0!(X'<9)
WRITE !?3,"Enter the number of cards you wish to print (1-8)"
GOTO NUM
+5 SET DGQUAN=X
+6 QUIT
+7 ;
+8 ;
MSG ;print error message if card can't be printed
+1 WRITE !,"Service connected or NSC status not entered...cannot print card"
+2 QUIT
+3 ;
+4 ;
OK ;ask if ok to print data cards if data missing
+1 SET DGFL=0
NEW S
WRITE !,"Do you still wish to emboss a patient data card"
SET %=2
DO YN^DICN
+2 IF %=0
WRITE !?3,"Enter 'Y'es to emboss a card, otherwise, 'N'o."
GOTO OK
+3 IF %=1
SET DGFL=1
+4 QUIT
+5 ;
+6 ;
EMBOS ; -- Ask if user wants to emboss (OLD) data card, downloads data to VIC.
+1 ; Called from DGREG00, DG10, and DG1010P
+2 ; -- Download VIC Data
+3 DO VIC^DGQESC5
+4 ;Do not do old card anymore patch 191
QUIT
OLD ; -- Creates old card, if flag set in MAS parameter file
+1 SET Y=$PIECE(^DG(43,1,0),U,28)
IF 'Y
QUIT
WRITE !,"EMBOSS (OLD) DATA CARD"
SET %=2
DO YN^DICN
IF %=-1!(%=2)
QUIT
+2 IF %=0
WRITE !," Enter YES to print patient data card for this patient, otherwise respond NO"
GOTO OLD
+3 IF %=1
DO EN
+4 QUIT
+5 ;
