Routine: BLRDPT61

BLRDPT61 ; IHS/DIR/FJE - Patient ID Utilities (cont.) ;

 ;;5.2;BLR;;NOV 01, 1997

 ;;MAS VERSION 5.0;

1 ;;ID Format Enter/Edit

 W ! S DIC="^DIC(8.2,",DIC(0)="AELMQ" D ^DIC K DIC G Q1:+Y<1

 S DA=+Y,DIE="^DIC(8.2,",DR="[DG ID FORMAT ENTER/EDIT]" D ^DIE G 1

Q1 K DIE,DR,DA,Y Q

2 ;;Eligibility Code Enter/Edit

 W ! S DIC="^DIC(8,",DIC(0)="AELMQ",DIC("DR")=8 D ^DIC K DIC G Q2:+Y<1

 S DA=+Y,DIE="^DIC(8,",DR="[DG ELIG ENTER/EDIT]" D ^DIE G 2

Q2 K DIE,DR,DA,Y

ASK ;

 Q:$S('$D(^DIC(8.2,+$P(^DIC(8,VAELG,0),U,10),0)):1,1:'$P(^(0),U,2))

 W !!,*7,"User Input Needed for '",$P(^DIC(8,VAELG,0),U),"' id:"

 S DIE="^DPT("_DFN_",""E"",",DR=.03,DA(1)=DFN,DA=VAELG D ^DIE

 W !!?5,"...",$P(^DIC(8,VAELG,0),U)

 K DIE,DR,DA,Y

WARN ; -- interaction warning

 I $P(X,U,2) W !!?5,*7,"WARNING: User interaction usually is required for this format."

BEG ;

 D NOW^%DTC S VASTART=%

END ;

 D NOW^%DTC S VAEND=%,L=0

 K XMY

 S XMSUB=$P($T(OPTS+VAOPT),";",4),XMDUZ=.5,XMTEXT="VATEXT(",XMY(DUZ)=""

 I VAOPT=3 S XMSUB=XMSUB_" (Format: "_$S($D(^DIC(8.2,VAFMT,0)):$P(^(0),U),1:"UNKNOWN")_")"

 I VAOPT=5 S XMSUB=XMSUB_" (Eligibility: "_$S($D(^DIC(8,VAELG,0)):$P(^(0),U),1:"UNKNOWN")_")"

 S L=L+1 S VATEXT(L,0)=" "

 S Y=VASTART,L=L+1 X ^DD("DD") S VATEXT(L,0)="  Job started   at "_Y

 S Y=VAEND,L=L+1 X ^DD("DD") S VATEXT(L,0)="  Job completed at "_Y

 D ^XMD

 K VAOPT,VASTART,VAEND,L,VATEXT,XMY,XMSUB,XMDUZ,XMTEXT,Y,% Q

TASK ;

 W !!?5,"The resetting of ID formats can take many hours."

 W !?5,"It is suggested that it be run at off-peak hours,"

 W !?5,"perferably over a weekend.",!

 K ZTSK S X=$T(OPTS+VAOPT),VARS=$P(X,";",5)

 F I=1:1 S Y=$P(VARS,"^",I) Q:Y=""  S ZTSAVE(Y)=""

 S ZTSAVE("VAOPT")="",ZTRTN="QUE"_VAOPT_"^BLRDPT60",ZTDESC=$P(X,";",4),ZTIO="" D ^%ZTLOAD

 I $D(ZTSK) W !!,"Job has been queued. (Task #",ZTSK,")",!,"A MailMan message will be sent to you when the job has completed."

TASKQ K ZTIO,ZTRTN,ZTDESC,ZTSAVE,VARS,Y,X,ZTSK Q

OPTS ; -- queue task list ;;opt#;description;vars to save

 ;;1;none

 ;;2;none

 ;;3;Reset ID Format;VAFMT

 ;;4;Reset Primary Eligibilty ID Format

 ;;5;Reset Specific Eligibilty ID Format;VAELG

 ;;6;none

 ;;7;Reset All ID Formats for all Patients

BLRDPT61  ; IHS/DIR/FJE - Patient ID Utilities (cont.) ;

 +1       ;;5.2;BLR;;NOV 01, 1997

 +2       ;

 +3       ;;MAS VERSION 5.0;

 +4       ;

1         ;;ID Format Enter/Edit

 +1        WRITE !

           SET DIC="^DIC(8.2,"

           SET DIC(0)="AELMQ"

           DO ^DIC

           KILL DIC

           IF +Y<1

               GOTO Q1

 +2        SET DA=+Y

           SET DIE="^DIC(8.2,"

           SET DR="[DG ID FORMAT ENTER/EDIT]"

           DO ^DIE

           GOTO 1

Q1         KILL DIE,DR,DA,Y

           QUIT

 +1       ;

2         ;;Eligibility Code Enter/Edit

 +1        WRITE !

           SET DIC="^DIC(8,"

           SET DIC(0)="AELMQ"

           SET DIC("DR")=8

           DO ^DIC

           KILL DIC

           IF +Y<1

               GOTO Q2

 +2        SET DA=+Y

           SET DIE="^DIC(8,"

           SET DR="[DG ELIG ENTER/EDIT]"

           DO ^DIE

           GOTO 2

Q2         KILL DIE,DR,DA,Y

 +1        QUIT

 +2       ;

ASK       ;

 +1        IF $SELECT('$DATA(^DIC(8.2,+$PIECE(^DIC(8,VAELG,0),U,10),0))

               QUIT

 +2        WRITE !!,*7,"User Input Needed for '",$PIECE(^DIC(8,VAELG,0),U),"' id:"

 +3        SET DIE="^DPT("_DFN_",""E"","

           SET DR=.03

           SET DA(1)=DFN

           SET DA=VAELG

           DO ^DIE

 +4        WRITE !!?5,"...",$PIECE(^DIC(8,VAELG,0),U)

 +5        KILL DIE,DR,DA,Y

 +6        QUIT

 +7       ;

WARN      ; -- interaction warning

 +1        IF $PIECE(X,U,2)

               WRITE !!?5,*7,"WARNING: User interaction usually is required for this format."

 +2        QUIT

 +3       ;

BEG       ;

 +1        DO NOW^%DTC

           SET VASTART=%

 +2        QUIT

 +3       ;

END       ;

 +1        DO NOW^%DTC

           SET VAEND=%

           SET L=0

 +2        KILL XMY

 +3        SET XMSUB=$PIECE($TEXT(OPTS+VAOPT),";",4)

           SET XMDUZ=.5

           SET XMTEXT="VATEXT("

           SET XMY(DUZ)=""

 +4        IF VAOPT=3

               SET XMSUB=XMSUB_" (Format: "_$SELECT($DATA(^DIC(8.2,VAFMT,0)):$PIECE(^(0),U),1:"UNKNOWN")_")"

 +5        IF VAOPT=5

               SET XMSUB=XMSUB_" (Eligibility: "_$SELECT($DATA(^DIC(8,VAELG,0)):$PIECE(^(0),U),1:"UNKNOWN")_")"

 +6        SET L=L+1

           SET VATEXT(L,0)=" "

 +7        SET Y=VASTART

           SET L=L+1

           XECUTE ^DD("DD")

           SET VATEXT(L,0)="  Job started   at "_Y

 +8        SET Y=VAEND

           SET L=L+1

           XECUTE ^DD("DD")

           SET VATEXT(L,0)="  Job completed at "_Y

 +9        DO ^XMD

 +10       KILL VAOPT,VASTART,VAEND,L,VATEXT,XMY,XMSUB,XMDUZ,XMTEXT,Y,%

           QUIT

 +11      ;

TASK      ;

 +1        WRITE !!?5,"The resetting of ID formats can take many hours."

 +2        WRITE !?5,"It is suggested that it be run at off-peak hours,"

 +3        WRITE !?5,"perferably over a weekend.",!

 +4        KILL ZTSK

           SET X=$TEXT(OPTS+VAOPT)

           SET VARS=$PIECE(X,";",5)

 +5        FOR I=1:1

               SET Y=$PIECE(VARS,"^",I)

               IF Y=""

                   QUIT

               SET ZTSAVE(Y)=""

 +6        SET ZTSAVE("VAOPT")=""

           SET ZTRTN="QUE"_VAOPT_"^BLRDPT60"

           SET ZTDESC=$PIECE(X,";",4)

           SET ZTIO=""

           DO ^%ZTLOAD

 +7        IF $DATA(ZTSK)

               WRITE !!,"Job has been queued. (Task #",ZTSK,")",!,"A MailMan message will be sent to you when the job has completed."

TASKQ      KILL ZTIO,ZTRTN,ZTDESC,ZTSAVE,VARS,Y,X,ZTSK

           QUIT

 +1       ;

OPTS      ; -- queue task list ;;opt#;description;vars to save

 +1       ;;1;none

 +2       ;;2;none

 +3       ;;3;Reset ID Format;VAFMT

 +4       ;;4;Reset Primary Eligibilty ID Format

 +5       ;;5;Reset Specific Eligibilty ID Format;VAELG

 +6       ;;6;none

 +7       ;;7;Reset All ID Formats for all Patients

BLRDPT61.m