DGQEMA.m

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       ;