| 1 | DGQEMPS ;RWA/SLC-DHW/OKC - EMBOSSER SPECIAL SUBROUTINES;04/08/85 4:36 PM ; 04 Oct 85 2:13 PM
|
|---|
| 2 | ;;5.3;Registration;;Aug 13, 1993
|
|---|
| 3 | END Q
|
|---|
| 4 | ;
|
|---|
| 5 | ;FileMan data reference
|
|---|
| 6 | ; Need only: DFN = patient internal number
|
|---|
| 7 | ; Y = field number desired
|
|---|
| 8 | FM ;
|
|---|
| 9 | Q
|
|---|
| 10 | ;
|
|---|
| 11 | ;CALCULATE 'SPECIAL CODE' FIELD FOR PATIENT DATA CARD
|
|---|
| 12 | SPEC D PER S Y=$S(Y=1:"WWI",Y=3:"SAW",1:"")
|
|---|
| 13 | I $D(^DPT(DFN,.362)) S D=^(.362),Y=$S($P(D,"^",12)["Y":"AA",1:"")_Y
|
|---|
| 14 | I $D(^DPT(DFN,.362)) S D=^(.362),Y=$S($P(D,"^",13)["Y":"HB",1:"")_Y
|
|---|
| 15 | I $D(^DPT(DFN,.52)),$P(^(.52),"^",5)="Y" S Y=Y_"POW"
|
|---|
| 16 | S Y=" "_Y,D=$L(Y),Y=$E(Y,D-6,D) Q
|
|---|
| 17 | ;
|
|---|
| 18 | ;CALCULATE ELIGIBILITY CODE
|
|---|
| 19 | 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)
|
|---|
| 20 | Q
|
|---|
| 21 | ;
|
|---|
| 22 | ;CALCULATE 'MODIFIER' FIELD FOR PATIENT DATA CARD
|
|---|
| 23 | MOD S Y="" I $D(^DPT(DFN,.321)),^(.321)?1"Y".E S Y="V"
|
|---|
| 24 | Q
|
|---|
| 25 | ;
|
|---|
| 26 | ;CALCULATE PERIOD OF SERVICE CODE
|
|---|
| 27 | 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)
|
|---|
| 28 | Q
|
|---|
