BMCRLP.m

BMCRLP ; IHS/PHXAO/TMJ - PRINT REFERRAL REPORT ;   

 ;;4.0;REFERRED CARE INFO SYSTEM;;JAN 09, 2006

 ;IHS/ITSC/FCJ ADDED NUMERIC DATE FORMAT PRINT

 ;4.0 IHS/ITSC/FCJ MODIFIED "R" OPTION, ALL REF WERE NOT PRINTED

 ;4.0 IHS/ITSC/FCJ ADDED SUFFIX TO PRINT WITH REFERRAL #

 ;

START ;EP - Set up header line, dash line

 S X=0,BMCHEAD="" F  S X=$O(^BMCRTMP(BMCRPT,12,X)) Q:X'=+X  S BMCHDR=$P(^BMCTSORT($P(^BMCRTMP(BMCRPT,12,X,0),U),0),U,6),BMCLENG=$P(^BMCRTMP(BMCRPT,12,X,0),U,2),BMCHDR=$E(BMCHDR,1,BMCLENG) D

 .S J=$L(BMCHDR),BMCHEAD=BMCHEAD_BMCHDR,K=$P(^BMCRTMP(BMCRPT,12,X,0),U,2)+1 F I=J:1:K S BMCHEAD=BMCHEAD_" "

 S BMCDASH="",$P(BMCDASH,"-",BMCTCW)="-"

 D COVPAGE^BMCRLP1 ;print cover page - note: if user ^'s out of cover page, processing continues

PROC ;process printing of report

 S BMCPG=0

 I BMCCTYP="T" G DONE ;--- if displaying only total, that was done in the cover page - go to done

 I BMCCTYP="N" D N^BMCRLP2 G TOT

 I '$D(^XTMP("BMCRL",BMCJOB,BMCBTH)) G DONE

 S (BMCSRTV,BMCFRST)="" K BMCQUIT

 F  S BMCSRTV=$O(^XTMP("BMCRL",BMCJOB,BMCBTH,"DATA HITS",BMCSRTV)) Q:BMCSRTV=""!($D(BMCQUIT))  D V

 G:$D(BMCQUIT) DONE

TOT ;

 G:$G(BMCCTYP)="R" DONE

 I $Y>(IOSL-4) D HEAD G:$D(BMCQUIT) DONE

 I $D(BMCRCNT) W !!!,"Total ",$S(BMCPTVS="P":"Patients",1:"Referrals"),":  ",BMCRCNT

 I $G(BMCPTVS)="R" W !,"Total Patients:  ",BMCPTCT

DONE ;

 D DONE^BMCRLP2

 Q

V ;GETS DATA HITS

 S BMCSCNT=0

 ;get readable sort value

 ;2.17.05 IHS/ITSC/FCJ MODIFIED NEXT LINE, IT WAS NOT PICKING UP ALL REF

 ;S BMCSRTR="",BMCREF=$O(^XTMP("BMCRL",BMCJOB,BMCBTH,"DATA HITS",BMCSRTV,0)) I BMCREF]"" S BMCCRIT=BMCSORT D

 S BMCSRTR="",BMCREF="" F  S BMCREF=$O(^XTMP("BMCRL",BMCJOB,BMCBTH,"DATA HITS",BMCSRTV,BMCREF)) Q:BMCREF'?1N.N  I BMCREF]"" S BMCCRIT=BMCSORT D

 .I $G(BMCCTYP)="R" D R^BMCRLP2 Q  ;2.17.05 IHS/ITSC/FCJ ADDED $G

 .I BMCPTVS="R" S BMCRREC=^BMCREF(BMCREF,0),DFN=$P(BMCRREC,U,3) X:$D(^BMCTSORT(BMCSORT,3)) ^(3) S BMCSRTR=BMCPRNT

 .I BMCPTVS="P" S DFN=BMCREF X:$D(^BMCTSORT(BMCSORT,3)) ^(3) S BMCSRTR=BMCPRNT

 I $G(BMCSPAG)!($D(BMCFRST)) D HEAD Q:$D(BMCQUIT)

 K BMCFRST

 S BMCREF=0 F  S BMCREF=$O(^XTMP("BMCRL",BMCJOB,BMCBTH,"DATA HITS",BMCSRTV,BMCREF)) Q:BMCREF'=+BMCREF!($D(BMCQUIT))  D

 .I BMCPTVS="R" S BMCRREC=^BMCREF(BMCREF,0),DFN=$P(BMCRREC,U,3) D PRINT Q

 .S DFN=BMCREF D PRINT

 Q:$D(BMCQUIT)

 I $Y>(IOSL-3) D HEAD Q:$D(BMCQUIT)

 W:$G(BMCSPAG) !!,"SUB-TOTAL for ",BMCSORV," ",BMCSRTR,":  ",BMCSCNT

 W:$G(BMCCTYP)="S" !,?10,$E(BMCSRTR,1,30),?45,$J(BMCSCNT,8)  ;2.17.05 IHS/ITSC/FCJ ADDED $G

 Q

PRINT ;

 S BMCSCNT=BMCSCNT+1 Q:$G(BMCCTYP)="S"  ;2.17.05 IHS/ITSC/FCJ ADDED $G

 K ^XTMP("BMCLINE",$J) S ^XTMP("BMCLINE",$J,1)=""

 I $Y>(IOSL-5) D HEAD Q:$D(BMCQUIT)

 S BMCI=0 F  S BMCI=$O(^BMCRTMP(BMCRPT,12,BMCI)) Q:BMCI'=+BMCI!($D(BMCQUIT))  S BMCCRIT=$P(^BMCRTMP(BMCRPT,12,BMCI,0),U) D

 .I '$P(^BMCTSORT(BMCCRIT,0),U,8) D SINGLE Q

 .D MULT

 .Q

 S BMCX=0 F  S BMCX=$O(^XTMP("BMCLINE",$J,BMCX)) Q:BMCX'=+BMCX!($D(BMCQUIT))  D

 .I $Y>(IOSL-4) D HEAD Q:$D(BMCQUIT)

 .W !,^XTMP("BMCLINE",$J,BMCX)

 Q

SINGLE ;process single valued item

 K BMCPRNT

 S BMCX=0

 X:$D(^BMCTSORT(BMCCRIT,3)) ^(3)

 S BMCLENG=$P(^BMCRTMP(BMCRPT,12,BMCI,0),U,2),BMCPRNT=$E(BMCPRNT,1,BMCLENG) D

 .S J=$L(BMCPRNT),^XTMP("BMCLINE",$J,1)=^XTMP("BMCLINE",$J,1)_BMCPRNT,K=$P(^BMCRTMP(BMCRPT,12,BMCI,0),U,2)+1 F I=J:1:K S ^XTMP("BMCLINE",$J,1)=^XTMP("BMCLINE",$J,1)_" "

 .S X=1 F  S X=$O(^XTMP("BMCLINE",$J,X)) Q:X'=+X  I $L(^XTMP("BMCLINE",$J,X))<$L(^XTMP("BMCLINE",$J,1)) S K=$L(^XTMP("BMCLINE",$J,X))+1,J=$L(^XTMP("BMCLINE",$J,1)) F I=K:1:J S ^XTMP("BMCLINE",$J,X)=^XTMP("BMCLINE",$J,X)_" "

 Q

MULT ;

 K BMCPRNT,BMCPRNM S (BMCX,BMCPCNT)=0

 X:$D(^BMCTSORT(BMCCRIT,3)) ^(3)

 I '$D(BMCPRNM) S BMCPRNT="--" D

 .S BMCLENG=$P(^BMCRTMP(BMCRPT,12,BMCI,0),U,2),BMCPRNT=$E(BMCPRNT,1,BMCLENG) D

 ..S J=$L(BMCPRNT),^XTMP("BMCLINE",$J,1)=^XTMP("BMCLINE",$J,1)_BMCPRNT,K=$P(^BMCRTMP(BMCRPT,12,BMCI,0),U,2)+1 F I=J:1:K S ^XTMP("BMCLINE",$J,1)=^XTMP("BMCLINE",$J,1)_" "

 S X=0 F  S X=$O(BMCPRNM(X)) Q:X'=+X  D

 .I X=1 D  Q

 ..S BMCLENG=$P(^BMCRTMP(BMCRPT,12,BMCI,0),U,2),BMCPRNT=$E(BMCPRNM(1),1,BMCLENG) D

 ...S J=$L(BMCPRNT),^XTMP("BMCLINE",$J,1)=^XTMP("BMCLINE",$J,1)_BMCPRNT,K=$P(^BMCRTMP(BMCRPT,12,BMCI,0),U,2)+1 F I=J:1:K S ^XTMP("BMCLINE",$J,1)=^XTMP("BMCLINE",$J,1)_" "

 .S BMCLENG=$P(^BMCRTMP(BMCRPT,12,BMCI,0),U,2),BMCPRNT=$E(BMCPRNM(X),1,BMCLENG) D

 ..I '$D(^XTMP("BMCLINE",$J,X)) S ^XTMP("BMCLINE",$J,X)="",K=$P(^BMCRTMP(BMCRPT,12,BMCI,0),U,2)+1,$P(^XTMP("BMCLINE",$J,X)," ",($L(^XTMP("BMCLINE",$J,1))-K))=""

 ..S J=$L(BMCPRNT),^XTMP("BMCLINE",$J,X)=^XTMP("BMCLINE",$J,X)_BMCPRNT,K=$P(^BMCRTMP(BMCRPT,12,BMCI,0),U,2)+1 F I=J:1:K S ^XTMP("BMCLINE",$J,X)=^XTMP("BMCLINE",$J,X)_" "

 S X=1 F  S X=$O(^XTMP("BMCLINE",$J,X)) Q:X'=+X  I $L(^XTMP("BMCLINE",$J,X))<$L(^XTMP("BMCLINE",$J,1)) S K=$L(^XTMP("BMCLINE",$J,X))+1,J=$L(^XTMP("BMCLINE",$J,1)) F I=K:1:J S ^XTMP("BMCLINE",$J,X)=^XTMP("BMCLINE",$J,X)_" "

 Q

DIQ ;EP FROM REPORT LIST FILE

 K BMCPRNT,BMCFILE,BMCFIEL

 S BMCFILE=$P($P(^BMCTSORT(BMCCRIT,0),U,4),","),BMCFIEL=$P($P(^(0),U,4),",",2)

 S DIQ(0)="ENI",DIQ="BMCPRNT(",DIC=BMCFILE,DR=BMCFIEL D EN^DIQ1 K DIC,DR,DIQ

 I BMCFIEL=".02" S BMCPRNT=BMCPRNT(BMCFILE,DA,BMCFIEL,"E")_$P($G(^BMCREF(DA,1)),U),BMCPRNT(BMCFILE,DA,BMCFIEL,"E")=BMCPRNT Q

 I '$D(BMCPRNT(BMCFILE,DA,BMCFIEL,"E")) S (BMCPRNT,BMCPRNT(BMCFILE,DA,BMCFIEL,"E"))="--" Q

 I $P(^BMCTSORT(BMCCRIT,0),U)="Date of Birth" S Y=BMCPRNT(BMCFILE,DA,BMCFIEL,"I") D DT^BMCOSUT S BMCPRNT=Y Q

 I $P(^BMCTSORT(BMCCRIT,0),U,2)="D" S Y=BMCPRNT(BMCFILE,DA,BMCFIEL,"I") D DT1^BMCOSUT S BMCPRNT=Y Q

 S BMCPRNT=BMCPRNT(BMCFILE,DA,BMCFIEL,"E")

 Q

HEAD ;ENTRY POINT

 D HEAD^BMCRLP2

 Q

BMCRLP    ; IHS/PHXAO/TMJ - PRINT REFERRAL REPORT ;   

 +1       ;;4.0;REFERRED CARE INFO SYSTEM;;JAN 09, 2006

 +2       ;IHS/ITSC/FCJ ADDED NUMERIC DATE FORMAT PRINT

 +3       ;4.0 IHS/ITSC/FCJ MODIFIED "R" OPTION, ALL REF WERE NOT PRINTED

 +4       ;4.0 IHS/ITSC/FCJ ADDED SUFFIX TO PRINT WITH REFERRAL #

 +5       ;

START     ;EP - Set up header line, dash line

 +1        SET X=0

           SET BMCHEAD=""

           FOR 

               SET X=$ORDER(^BMCRTMP(BMCRPT,12,X))

               IF X'=+X

                   QUIT 

               SET BMCHDR=$PIECE(^BMCTSORT($PIECE(^BMCRTMP(BMCRPT,12,X,0),U),0),U,6)

               SET BMCLENG=$PIECE(^BMCRTMP(BMCRPT,12,X,0),U,2)

               SET BMCHDR=$EXTRACT(BMCHDR,1,BMCLENG)

               Begin DoDot:1

 +2                SET J=$LENGTH(BMCHDR)

                   SET BMCHEAD=BMCHEAD_BMCHDR

                   SET K=$PIECE(^BMCRTMP(BMCRPT,12,X,0),U,2)+1

                   FOR I=J:1:K

                       SET BMCHEAD=BMCHEAD_" "

               End DoDot:1

 +3        SET BMCDASH=""

           SET $PIECE(BMCDASH,"-",BMCTCW)="-"

 +4       ;print cover page - note: if user ^'s out of cover page, processing continues

           DO COVPAGE^BMCRLP1

PROC      ;process printing of report

 +1        SET BMCPG=0

 +2       ;--- if displaying only total, that was done in the cover page - go to done

           IF BMCCTYP="T"

               GOTO DONE

 +3        IF BMCCTYP="N"

               DO N^BMCRLP2

               GOTO TOT

 +4        IF '$DATA(^XTMP("BMCRL",BMCJOB,BMCBTH))

               GOTO DONE

 +5        SET (BMCSRTV,BMCFRST)=""

           KILL BMCQUIT

 +6        FOR 

               SET BMCSRTV=$ORDER(^XTMP("BMCRL",BMCJOB,BMCBTH,"DATA HITS",BMCSRTV))

               IF BMCSRTV=""!($DATA(BMCQUIT))

                   QUIT 

               DO V

 +7        IF $DATA(BMCQUIT)

               GOTO DONE

TOT       ;

 +1        IF $GET(BMCCTYP)="R"

               GOTO DONE

 +2        IF $Y>(IOSL-4)

               DO HEAD

               IF $DATA(BMCQUIT)

                   GOTO DONE

 +3        IF $DATA(BMCRCNT)

               WRITE !!!,"Total ",$SELECT(BMCPTVS="P":"Patients",1:"Referrals"),":  ",BMCRCNT

 +4        IF $GET(BMCPTVS)="R"

               WRITE !,"Total Patients:  ",BMCPTCT

DONE      ;

 +1        DO DONE^BMCRLP2

 +2        QUIT 

V         ;GETS DATA HITS

 +1        SET BMCSCNT=0

 +2       ;get readable sort value

 +3       ;2.17.05 IHS/ITSC/FCJ MODIFIED NEXT LINE, IT WAS NOT PICKING UP ALL REF

 +4       ;S BMCSRTR="",BMCREF=$O(^XTMP("BMCRL",BMCJOB,BMCBTH,"DATA HITS",BMCSRTV,0)) I BMCREF]"" S BMCCRIT=BMCSORT D

 +5        SET BMCSRTR=""

           SET BMCREF=""

           FOR 

               SET BMCREF=$ORDER(^XTMP("BMCRL",BMCJOB,BMCBTH,"DATA HITS",BMCSRTV,BMCREF))

               IF BMCREF'?1N.N

                   QUIT 

               IF BMCREF]""

                   SET BMCCRIT=BMCSORT

                   Begin DoDot:1

 +6       ;2.17.05 IHS/ITSC/FCJ ADDED $G

                       IF $GET(BMCCTYP)="R"

                           DO R^BMCRLP2

                           QUIT 

 +7                    IF BMCPTVS="R"

                           SET BMCRREC=^BMCREF(BMCREF,0)

                           SET DFN=$PIECE(BMCRREC,U,3)

                           IF $DATA(^BMCTSORT(BMCSORT,3))

                               XECUTE ^(3)

                           SET BMCSRTR=BMCPRNT

 +8                    IF BMCPTVS="P"

                           SET DFN=BMCREF

                           IF $DATA(^BMCTSORT(BMCSORT,3))

                               XECUTE ^(3)

                           SET BMCSRTR=BMCPRNT

                   End DoDot:1

 +9        IF $GET(BMCSPAG)!($DATA(BMCFRST))

               DO HEAD

               IF $DATA(BMCQUIT)

                   QUIT 

 +10       KILL BMCFRST

 +11       SET BMCREF=0

           FOR 

               SET BMCREF=$ORDER(^XTMP("BMCRL",BMCJOB,BMCBTH,"DATA HITS",BMCSRTV,BMCREF))

               IF BMCREF'=+BMCREF!($DATA(BMCQUIT))

                   QUIT 

               Begin DoDot:1

 +12               IF BMCPTVS="R"

                       SET BMCRREC=^BMCREF(BMCREF,0)

                       SET DFN=$PIECE(BMCRREC,U,3)

                       DO PRINT

                       QUIT 

 +13               SET DFN=BMCREF

                   DO PRINT

               End DoDot:1

 +14       IF $DATA(BMCQUIT)

               QUIT 

 +15       IF $Y>(IOSL-3)

               DO HEAD

               IF $DATA(BMCQUIT)

                   QUIT 

 +16       IF $GET(BMCSPAG)

               WRITE !!,"SUB-TOTAL for ",BMCSORV," ",BMCSRTR,":  ",BMCSCNT

 +17      ;2.17.05 IHS/ITSC/FCJ ADDED $G

           IF $GET(BMCCTYP)="S"

               WRITE !,?10,$EXTRACT(BMCSRTR,1,30),?45,$JUSTIFY(BMCSCNT,8)

 +18       QUIT 

PRINT     ;

 +1       ;2.17.05 IHS/ITSC/FCJ ADDED $G

           SET BMCSCNT=BMCSCNT+1

           IF $GET(BMCCTYP)="S"

               QUIT 

 +2        KILL ^XTMP("BMCLINE",$JOB)

           SET ^XTMP("BMCLINE",$JOB,1)=""

 +3        IF $Y>(IOSL-5)

               DO HEAD

               IF $DATA(BMCQUIT)

                   QUIT 

 +4        SET BMCI=0

           FOR 

               SET BMCI=$ORDER(^BMCRTMP(BMCRPT,12,BMCI))

               IF BMCI'=+BMCI!($DATA(BMCQUIT))

                   QUIT 

               SET BMCCRIT=$PIECE(^BMCRTMP(BMCRPT,12,BMCI,0),U)

               Begin DoDot:1

 +5                IF '$PIECE(^BMCTSORT(BMCCRIT,0),U,8)

                       DO SINGLE

                       QUIT 

 +6                DO MULT

 +7                QUIT 

               End DoDot:1

 +8        SET BMCX=0

           FOR 

               SET BMCX=$ORDER(^XTMP("BMCLINE",$JOB,BMCX))

               IF BMCX'=+BMCX!($DATA(BMCQUIT))

                   QUIT 

               Begin DoDot:1

 +9                IF $Y>(IOSL-4)

                       DO HEAD

                       IF $DATA(BMCQUIT)

                           QUIT 

 +10               WRITE !,^XTMP("BMCLINE",$JOB,BMCX)

               End DoDot:1

 +11       QUIT 

SINGLE    ;process single valued item

 +1        KILL BMCPRNT

 +2        SET BMCX=0

 +3        IF $DATA(^BMCTSORT(BMCCRIT,3))

               XECUTE ^(3)

 +4        SET BMCLENG=$PIECE(^BMCRTMP(BMCRPT,12,BMCI,0),U,2)

           SET BMCPRNT=$EXTRACT(BMCPRNT,1,BMCLENG)

           Begin DoDot:1

 +5            SET J=$LENGTH(BMCPRNT)

               SET ^XTMP("BMCLINE",$JOB,1)=^XTMP("BMCLINE",$JOB,1)_BMCPRNT

               SET K=$PIECE(^BMCRTMP(BMCRPT,12,BMCI,0),U,2)+1

               FOR I=J:1:K

                   SET ^XTMP("BMCLINE",$JOB,1)=^XTMP("BMCLINE",$JOB,1)_" "

 +6            SET X=1

               FOR 

                   SET X=$ORDER(^XTMP("BMCLINE",$JOB,X))

                   IF X'=+X

                       QUIT 

                   IF $LENGTH(^XTMP("BMCLINE",$JOB,X))<$LENGTH(^XTMP("BMCLINE",$JOB,1))

                       SET K=$LENGTH(^XTMP("BMCLINE",$JOB,X))+1

                       SET J=$LENGTH(^XTMP("BMCLINE",$JOB,1))

                       FOR I=K:1:J

                           SET ^XTMP("BMCLINE",$JOB,X)=^XTMP("BMCLINE",$JOB,X)_" "

           End DoDot:1

 +7        QUIT 

MULT      ;

 +1        KILL BMCPRNT,BMCPRNM

           SET (BMCX,BMCPCNT)=0

 +2        IF $DATA(^BMCTSORT(BMCCRIT,3))

               XECUTE ^(3)

 +3        IF '$DATA(BMCPRNM)

               SET BMCPRNT="--"

               Begin DoDot:1

 +4                SET BMCLENG=$PIECE(^BMCRTMP(BMCRPT,12,BMCI,0),U,2)

                   SET BMCPRNT=$EXTRACT(BMCPRNT,1,BMCLENG)

                   Begin DoDot:2

 +5                    SET J=$LENGTH(BMCPRNT)

                       SET ^XTMP("BMCLINE",$JOB,1)=^XTMP("BMCLINE",$JOB,1)_BMCPRNT

                       SET K=$PIECE(^BMCRTMP(BMCRPT,12,BMCI,0),U,2)+1

                       FOR I=J:1:K

                           SET ^XTMP("BMCLINE",$JOB,1)=^XTMP("BMCLINE",$JOB,1)_" "

                   End DoDot:2

               End DoDot:1

 +6        SET X=0

           FOR 

               SET X=$ORDER(BMCPRNM(X))

               IF X'=+X

                   QUIT 

               Begin DoDot:1

 +7                IF X=1

                       Begin DoDot:2

 +8                        SET BMCLENG=$PIECE(^BMCRTMP(BMCRPT,12,BMCI,0),U,2)

                           SET BMCPRNT=$EXTRACT(BMCPRNM(1),1,BMCLENG)

                           Begin DoDot:3

 +9                            SET J=$LENGTH(BMCPRNT)

                               SET ^XTMP("BMCLINE",$JOB,1)=^XTMP("BMCLINE",$JOB,1)_BMCPRNT

                               SET K=$PIECE(^BMCRTMP(BMCRPT,12,BMCI,0),U,2)+1

                               FOR I=J:1:K

                                   SET ^XTMP("BMCLINE",$JOB,1)=^XTMP("BMCLINE",$JOB,1)_" "

                           End DoDot:3

                       End DoDot:2

                       QUIT 

 +10               SET BMCLENG=$PIECE(^BMCRTMP(BMCRPT,12,BMCI,0),U,2)

                   SET BMCPRNT=$EXTRACT(BMCPRNM(X),1,BMCLENG)

                   Begin DoDot:2

 +11                   IF '$DATA(^XTMP("BMCLINE",$JOB,X))

                           SET ^XTMP("BMCLINE",$JOB,X)=""

                           SET K=$PIECE(^BMCRTMP(BMCRPT,12,BMCI,0),U,2)+1

                           SET $PIECE(^XTMP("BMCLINE",$JOB,X)," ",($LENGTH(^XTMP("BMCLINE",$JOB,1))-K))=""

 +12                   SET J=$LENGTH(BMCPRNT)

                       SET ^XTMP("BMCLINE",$JOB,X)=^XTMP("BMCLINE",$JOB,X)_BMCPRNT

                       SET K=$PIECE(^BMCRTMP(BMCRPT,12,BMCI,0),U,2)+1

                       FOR I=J:1:K

                           SET ^XTMP("BMCLINE",$JOB,X)=^XTMP("BMCLINE",$JOB,X)_" "

                   End DoDot:2

               End DoDot:1

 +13       SET X=1

           FOR 

               SET X=$ORDER(^XTMP("BMCLINE",$JOB,X))

               IF X'=+X

                   QUIT 

               IF $LENGTH(^XTMP("BMCLINE",$JOB,X))<$LENGTH(^XTMP("BMCLINE",$JOB,1))

                   SET K=$LENGTH(^XTMP("BMCLINE",$JOB,X))+1

                   SET J=$LENGTH(^XTMP("BMCLINE",$JOB,1))

                   FOR I=K:1:J

                       SET ^XTMP("BMCLINE",$JOB,X)=^XTMP("BMCLINE",$JOB,X)_" "

 +14       QUIT 

DIQ       ;EP FROM REPORT LIST FILE

 +1        KILL BMCPRNT,BMCFILE,BMCFIEL

 +2        SET BMCFILE=$PIECE($PIECE(^BMCTSORT(BMCCRIT,0),U,4),",")

           SET BMCFIEL=$PIECE($PIECE(^(0),U,4),",",2)

 +3        SET DIQ(0)="ENI"

           SET DIQ="BMCPRNT("

           SET DIC=BMCFILE

           SET DR=BMCFIEL

           DO EN^DIQ1

           KILL DIC,DR,DIQ

 +4        IF BMCFIEL=".02"

               SET BMCPRNT=BMCPRNT(BMCFILE,DA,BMCFIEL,"E")_$PIECE($GET(^BMCREF(DA,1)),U)

               SET BMCPRNT(BMCFILE,DA,BMCFIEL,"E")=BMCPRNT

               QUIT 

 +5        IF '$DATA(BMCPRNT(BMCFILE,DA,BMCFIEL,"E"))

               SET (BMCPRNT,BMCPRNT(BMCFILE,DA,BMCFIEL,"E"))="--"

               QUIT 

 +6        IF $PIECE(^BMCTSORT(BMCCRIT,0),U)="Date of Birth"

               SET Y=BMCPRNT(BMCFILE,DA,BMCFIEL,"I")

               DO DT^BMCOSUT

               SET BMCPRNT=Y

               QUIT 

 +7        IF $PIECE(^BMCTSORT(BMCCRIT,0),U,2)="D"

               SET Y=BMCPRNT(BMCFILE,DA,BMCFIEL,"I")

               DO DT1^BMCOSUT

               SET BMCPRNT=Y

               QUIT 

 +8        SET BMCPRNT=BMCPRNT(BMCFILE,DA,BMCFIEL,"E")

 +9        QUIT 

HEAD      ;ENTRY POINT

 +1        DO HEAD^BMCRLP2

 +2        QUIT