DGQEMPS.m

DGQEMPS ;RWA/SLC-DHW/OKC - EMBOSSER SPECIAL SUBROUTINES;04/08/85  4:36 PM ; 04 Oct 85  2:13 PM

 ;;5.3;Registration;**1015**;Aug 13, 1993;Build 21

END Q

 ;

 ;FileMan data reference

 ;      Need only: DFN = patient internal number

 ;                   Y = field number desired

FM ;

 Q

 ;

 ;CALCULATE 'SPECIAL CODE' FIELD FOR PATIENT DATA CARD

SPEC D PER S Y=$S(Y=1:"WWI",Y=3:"SAW",1:"")

 I $D(^DPT(DFN,.362)) S D=^(.362),Y=$S($P(D,"^",12)["Y":"AA",1:"")_Y

 I $D(^DPT(DFN,.362)) S D=^(.362),Y=$S($P(D,"^",13)["Y":"HB",1:"")_Y

 I $D(^DPT(DFN,.52)),$P(^(.52),"^",5)="Y" S Y=Y_"POW"

 S Y="       "_Y,D=$L(Y),Y=$E(Y,D-6,D) Q

 ;

 ;CALCULATE ELIGIBILITY CODE

ELIG S Y="" I $D(^DPT(DFN,.36)) S X=$P(^(.36),"^",1) I X,$D(^DIC(8,X,0)) S Y=$P(^(0),"^",4)

 Q

 ;

 ;CALCULATE 'MODIFIER' FIELD FOR PATIENT DATA CARD

MOD S Y="" I $D(^DPT(DFN,.321)),^(.321)?1"Y".E S Y="V"

 Q

 ;

 ;CALCULATE PERIOD OF SERVICE CODE

PER S Y="" I $D(^DPT(DFN,.32)) S X=$P(^(.32),"^",3) I X,$D(^DIC(21,X,0)) S Y=$P(^(0),"^",3)

 Q

DGQEMPS   ;RWA/SLC-DHW/OKC - EMBOSSER SPECIAL SUBROUTINES;04/08/85  4:36 PM ; 04 Oct 85  2:13 PM

 +1       ;;5.3;Registration;**1015**;Aug 13, 1993;Build 21

END        QUIT 

 +1       ;

 +2       ;FileMan data reference

 +3       ;      Need only: DFN = patient internal number

 +4       ;                   Y = field number desired

FM        ;

 +1        QUIT 

 +2       ;

 +3       ;CALCULATE 'SPECIAL CODE' FIELD FOR PATIENT DATA CARD

SPEC       DO PER

           SET Y=$SELECT(Y=1:"WWI",Y=3:"SAW",1:"")

 +1        IF $DATA(^DPT(DFN,.362))

               SET D=^(.362)

               SET Y=$SELECT($PIECE(D,"^",12)["Y":"AA",1:"")_Y

 +2        IF $DATA(^DPT(DFN,.362))

               SET D=^(.362)

               SET Y=$SELECT($PIECE(D,"^",13)["Y":"HB",1:"")_Y

 +3        IF $DATA(^DPT(DFN,.52))

               IF $PIECE(^(.52),"^",5)="Y"

                   SET Y=Y_"POW"

 +4        SET Y="       "_Y

           SET D=$LENGTH(Y)

           SET Y=$EXTRACT(Y,D-6,D)

           QUIT 

 +5       ;

 +6       ;CALCULATE ELIGIBILITY CODE

ELIG       SET Y=""

           IF $DATA(^DPT(DFN,.36))

               SET X=$PIECE(^(.36),"^",1)

               IF X

                   IF $DATA(^DIC(8,X,0))

                       SET Y=$PIECE(^(0),"^",4)

 +1        QUIT 

 +2       ;

 +3       ;CALCULATE 'MODIFIER' FIELD FOR PATIENT DATA CARD

MOD        SET Y=""

           IF $DATA(^DPT(DFN,.321))

               IF ^(.321)?1"Y".E

                   SET Y="V"

 +1        QUIT 

 +2       ;

 +3       ;CALCULATE PERIOD OF SERVICE CODE

PER        SET Y=""

           IF $DATA(^DPT(DFN,.32))

               SET X=$PIECE(^(.32),"^",3)

               IF X

                   IF $DATA(^DIC(21,X,0))

                       SET Y=$PIECE(^(0),"^",3)

 +1        QUIT