VADPT61 ;ALB/MJK - Patient ID Utilities (cont.); 12 AUG 89 @1200
;;5.3;Registration,;**749**;Aug 13, 1993;Build 10
;
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
Q
;
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
Q
;
WARN ; -- interaction warning
I $P(X,U,2) W !!?5,*7,"WARNING: User interaction usually is required for this format."
Q
;
BEG ;
S VASTART=$$NOW^XLFDT
Q
;
END ;
S VAEND=$$NOW^XLFDT,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_"^VADPT60",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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVADPT61 2258 printed Nov 22, 2024@18:11:21 Page 2
VADPT61 ;ALB/MJK - Patient ID Utilities (cont.); 12 AUG 89 @1200
+1 ;;5.3;Registration,;**749**;Aug 13, 1993;Build 10
+2 ;
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 SET VASTART=$$NOW^XLFDT
+2 QUIT
+3 ;
END ;
+1 SET VAEND=$$NOW^XLFDT
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_"^VADPT60"
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
