Ignore:
Timestamp:
Dec 4, 2009, 12:11:15 AM (14 years ago)
Author:
George Lilly
Message:

revised back to 6/30/08 version

File:
1 edited

Legend:

Unmodified
Added
Removed

  • WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VADPT61.m

    r613 r623  
    1 VADPT61 ;ALB/MJK - Patient ID Utilities (cont.); 12 AUG 89 @1200
    2         ;;5.3;Registration,;**749**;Aug 13, 1993;Build 10
    3         ;
    4 1       ;;ID Format Enter/Edit
    5         W ! S DIC="^DIC(8.2,",DIC(0)="AELMQ" D ^DIC K DIC G Q1:+Y<1
    6         S DA=+Y,DIE="^DIC(8.2,",DR="[DG ID FORMAT ENTER/EDIT]" D ^DIE G 1
    7 Q1      K DIE,DR,DA,Y Q
    8         ;
    9 2       ;;Eligibility Code Enter/Edit
    10         W ! S DIC="^DIC(8,",DIC(0)="AELMQ",DIC("DR")=8 D ^DIC K DIC G Q2:+Y<1
    11         S DA=+Y,DIE="^DIC(8,",DR="[DG ELIG ENTER/EDIT]" D ^DIE G 2
    12 Q2      K DIE,DR,DA,Y
    13         Q
    14         ;
    15 ASK     ;
    16         Q:$S('$D(^DIC(8.2,+$P(^DIC(8,VAELG,0),U,10),0)):1,1:'$P(^(0),U,2))
    17         W !!,*7,"User Input Needed for '",$P(^DIC(8,VAELG,0),U),"' id:"
    18         S DIE="^DPT("_DFN_",""E"",",DR=.03,DA(1)=DFN,DA=VAELG D ^DIE
    19         W !!?5,"...",$P(^DIC(8,VAELG,0),U)
    20         K DIE,DR,DA,Y
    21         Q
    22         ;
    23 WARN    ; -- interaction warning
    24         I $P(X,U,2) W !!?5,*7,"WARNING: User interaction usually is required for this format."
    25         Q
    26         ;
    27 BEG     ;
    28         S VASTART=$$NOW^XLFDT
    29         Q
    30         ;
    31 END     ;
    32         S VAEND=$$NOW^XLFDT,L=0
    33         K XMY
    34         S XMSUB=$P($T(OPTS+VAOPT),";",4),XMDUZ=.5,XMTEXT="VATEXT(",XMY(DUZ)=""
    35         I VAOPT=3 S XMSUB=XMSUB_" (Format: "_$S($D(^DIC(8.2,VAFMT,0)):$P(^(0),U),1:"UNKNOWN")_")"
    36         I VAOPT=5 S XMSUB=XMSUB_" (Eligibility: "_$S($D(^DIC(8,VAELG,0)):$P(^(0),U),1:"UNKNOWN")_")"
    37         S L=L+1 S VATEXT(L,0)=" "
    38         S Y=VASTART,L=L+1 X ^DD("DD") S VATEXT(L,0)="  Job started   at "_Y
    39         S Y=VAEND,L=L+1 X ^DD("DD") S VATEXT(L,0)="  Job completed at "_Y
    40         D ^XMD
    41         K VAOPT,VASTART,VAEND,L,VATEXT,XMY,XMSUB,XMDUZ,XMTEXT,Y,% Q
    42         ;
    43 TASK    ;
    44         W !!?5,"The resetting of ID formats can take many hours."
    45         W !?5,"It is suggested that it be run at off-peak hours,"
    46         W !?5,"perferably over a weekend.",!
    47         K ZTSK S X=$T(OPTS+VAOPT),VARS=$P(X,";",5)
    48         F I=1:1 S Y=$P(VARS,"^",I) Q:Y=""  S ZTSAVE(Y)=""
    49         S ZTSAVE("VAOPT")="",ZTRTN="QUE"_VAOPT_"^VADPT60",ZTDESC=$P(X,";",4),ZTIO="" D ^%ZTLOAD
    50         I $D(ZTSK) W !!,"Job has been queued. (Task #",ZTSK,")",!,"A MailMan message will be sent to you when the job has completed."
    51 TASKQ   K ZTIO,ZTRTN,ZTDESC,ZTSAVE,VARS,Y,X,ZTSK Q
    52         ;
    53 OPTS    ; -- queue task list ;;opt#;description;vars to save
    54         ;;1;none
    55         ;;2;none
    56         ;;3;Reset ID Format;VAFMT
    57         ;;4;Reset Primary Eligibilty ID Format
    58         ;;5;Reset Specific Eligibilty ID Format;VAELG
    59         ;;6;none
    60         ;;7;Reset All ID Formats for all Patients
     1VADPT61 ;ALB/MJK - Patient ID Utilities (cont.); 12 AUG 89 @1200
     2 ;;5.3;Registration;;Aug 13, 1993
     3 ;
     41 ;;ID Format Enter/Edit
     5 W ! S DIC="^DIC(8.2,",DIC(0)="AELMQ" D ^DIC K DIC G Q1:+Y<1
     6 S DA=+Y,DIE="^DIC(8.2,",DR="[DG ID FORMAT ENTER/EDIT]" D ^DIE G 1
     7Q1 K DIE,DR,DA,Y Q
     8 ;
     92 ;;Eligibility Code Enter/Edit
     10 W ! S DIC="^DIC(8,",DIC(0)="AELMQ",DIC("DR")=8 D ^DIC K DIC G Q2:+Y<1
     11 S DA=+Y,DIE="^DIC(8,",DR="[DG ELIG ENTER/EDIT]" D ^DIE G 2
     12Q2 K DIE,DR,DA,Y
     13 Q
     14 ;
     15ASK ;
     16 Q:$S('$D(^DIC(8.2,+$P(^DIC(8,VAELG,0),U,10),0)):1,1:'$P(^(0),U,2))
     17 W !!,*7,"User Input Needed for '",$P(^DIC(8,VAELG,0),U),"' id:"
     18 S DIE="^DPT("_DFN_",""E"",",DR=.03,DA(1)=DFN,DA=VAELG D ^DIE
     19 W !!?5,"...",$P(^DIC(8,VAELG,0),U)
     20 K DIE,DR,DA,Y
     21 Q
     22 ;
     23WARN ; -- interaction warning
     24 I $P(X,U,2) W !!?5,*7,"WARNING: User interaction usually is required for this format."
     25 Q
     26 ;
     27BEG ;
     28 D NOW^%DTC S VASTART=%
     29 Q
     30 ;
     31END ;
     32 D NOW^%DTC S VAEND=%,L=0
     33 K XMY
     34 S XMSUB=$P($T(OPTS+VAOPT),";",4),XMDUZ=.5,XMTEXT="VATEXT(",XMY(DUZ)=""
     35 I VAOPT=3 S XMSUB=XMSUB_" (Format: "_$S($D(^DIC(8.2,VAFMT,0)):$P(^(0),U),1:"UNKNOWN")_")"
     36 I VAOPT=5 S XMSUB=XMSUB_" (Eligibility: "_$S($D(^DIC(8,VAELG,0)):$P(^(0),U),1:"UNKNOWN")_")"
     37 S L=L+1 S VATEXT(L,0)=" "
     38 S Y=VASTART,L=L+1 X ^DD("DD") S VATEXT(L,0)="  Job started   at "_Y
     39 S Y=VAEND,L=L+1 X ^DD("DD") S VATEXT(L,0)="  Job completed at "_Y
     40 D ^XMD
     41 K VAOPT,VASTART,VAEND,L,VATEXT,XMY,XMSUB,XMDUZ,XMTEXT,Y,% Q
     42 ;
     43TASK ;
     44 W !!?5,"The resetting of ID formats can take many hours."
     45 W !?5,"It is suggested that it be run at off-peak hours,"
     46 W !?5,"perferably over a weekend.",!
     47 K ZTSK S X=$T(OPTS+VAOPT),VARS=$P(X,";",5)
     48 F I=1:1 S Y=$P(VARS,"^",I) Q:Y=""  S ZTSAVE(Y)=""
     49 S ZTSAVE("VAOPT")="",ZTRTN="QUE"_VAOPT_"^VADPT60",ZTDESC=$P(X,";",4),ZTIO="" D ^%ZTLOAD
     50 I $D(ZTSK) W !!,"Job has been queued. (Task #",ZTSK,")",!,"A MailMan message will be sent to you when the job has completed."
     51TASKQ K ZTIO,ZTRTN,ZTDESC,ZTSAVE,VARS,Y,X,ZTSK Q
     52 ;
     53OPTS ; -- queue task list ;;opt#;description;vars to save
     54 ;;1;none
     55 ;;2;none
     56 ;;3;Reset ID Format;VAFMT
     57 ;;4;Reset Primary Eligibilty ID Format
     58 ;;5;Reset Specific Eligibilty ID Format;VAELG
     59 ;;6;none
     60 ;;7;Reset All ID Formats for all Patients
Note: See TracChangeset for help on using the changeset viewer.