DGENU ;ALB/CJM,ISA/KWP,Zoltan,LBD,EG,CKN,ERC,TMK,PWC,TDM,JLS,HM - Enrollment Utilities ;04/24/2006 9:20 AM
;;5.3;Registration;**121,122,147,232,314,564,624,672,659,653,688,536,838,841,909,940,972,952,993**;Aug 13,1993;Build 92
;
DISPLAY(DFN) ;
;Description: Display status message, current enrollment and
; preferred facility information
;Input:
; DFN - Patient IEN
; Output: none
;
N STATUS
S STATUS=$$STATUS^DGENA(DFN)
I 'STATUS W !!,"Patient is NOT enrolled in the VA Patient Enrollment System..."
E I STATUS=2 D
.W !!,"Patient is enrolled in the VA Patient Enrollment System..."
; Purple Heart added status 21
E I (STATUS=9)!(STATUS=1)!(STATUS=15)!(STATUS=16)!(STATUS=17)!(STATUS=18)!(STATUS=21) D
.W !!,"Application is pending for enrollment in the VA Patient Enrollment System..."
E D
.W !!,"Patient is NOT enrolled in the VA Patient Enrollment System..."
D CUR(DFN)
Q
;
CUR(DFN) ;
;Description - displays current enrollment, category, enrollment
; group threshold, preferred facility and source designation
;
N FACNAME,PREFAC,PFSRC,DGEGT,DGEGTIEN,DGENCAT,DGENR,IORVON,IORVOFF
I $$GET^DGENA($$FINDCUR^DGENA(DFN),.DGENR)
;Get enrollment category
S DGENCAT=$$CATEGORY^DGENA4(DFN)
;Display Category in reverse video
D REV
;Get enrollment group threshold
S DGEGTIEN=$$FINDCUR^DGENEGT
S DGEGT=$$GET^DGENEGT(DGEGTIEN,.DGEGT)
;Preferred facility
S PREFAC=$$PREF^DGENPTA(DFN,.FACNAME)
;Source Designation
S PFSRC=$$GET1^DIQ(2,DFN_",",27.03)
W !?3,"Enrollment Date",?35,": ",$S('$G(DGENR("DATE")):"-none-",1:$$EXT^DGENU("DATE",DGENR("DATE")))
W !?3,"Application Date",?35,": ",$S('$G(DGENR("APP")):"-none-",1:$$EXT^DGENU("DATE",DGENR("APP")))
W !?3,IORVON,"Enrollment Category : ",$S($G(DGENCAT)="":"-none-",1:$$EXTERNAL^DILFD(27.15,.02,"",DGENCAT)),IORVOFF
W !?3,"Enrollment Status",?35,": ",$S($G(DGENR("STATUS"))="":"-none-",1:$$EXT^DGENU("STATUS",DGENR("STATUS")))
W !?3,"Enrollment Priority",?35,": ",$S($G(DGENR("PRIORITY"))="":"-none-",1:DGENR("PRIORITY")),$S($G(DGENR("SUBGRP"))="":"",1:$$EXT("SUBGRP",DGENR("SUBGRP")))
W !?3,"Preferred Facility",?35,": ",$S($G(FACNAME)'="":FACNAME,1:"-none-")
W !?3,"Preferred Facility Source",?35,": ",$S($G(PFSRC)'="":PFSRC,1:"-none-")
W !?3,"Enrollment Group Threshold",?35,": ",$S($G(DGEGT("PRIORITY"))="":"-none-",1:$$EXTERNAL^DILFD(27.16,.02,"",$G(DGEGT("PRIORITY")))),$S($G(DGEGT("SUBGRP"))="":"",1:$$EXTERNAL^DILFD(27.16,.03,"",$G(DGEGT("SUBGRP"))))
W !
Q
REV ;Get variables to display text in reverse video
N X
S X="IORVON;IORVOFF"
D ENDR^%ZISS
Q
PATID(DFN) ;
;Description - Called by FileMan as an identifier for the Patient file.
;Displays current enrollment status, priority, and preferred facility.
;
;Input:
; DFN - ien to Patient file
;
N PREFAC,DGENR,OUTPUT
I '$$GET^DGENA($$FINDCUR^DGENA(DFN),.DGENR) D
.S OUTPUT="NO ENROLLMENT APPLICATION ON FILE "
E D
.S OUTPUT=$E("PRIORITY:"_DGENR("PRIORITY")_" ",1,12)_$E("STATUS:"_$$EXT^DGENU("STATUS",DGENR("STATUS"))_" ",1,26)
S PREFAC=$$PREF^DGENPTA(DFN)
S:PREFAC OUTPUT=OUTPUT_"PREFERRED FACILITY:"_$P($G(^DIC(4,PREFAC,99)),"^")
I $G(IOM) I ($X#$G(IOM))<6 D
.D EN^DDIOL(OUTPUT,,"?($X+(10-($X#IOM)))")
E D
.D EN^DDIOL(OUTPUT,,"!?10")
Q
;
EXT(SUB,VAL) ;
;Description: Given the subscript used in the PATIENT ENROLLMENT array,
; and a field value, returns the external representation of the
; value, as defined in the fields output transform of the PATIENT
; ENROLLMENT file.
;Input:
; SUB - subscript in the array defined by the PATIENT ENROLLMENT object
; VAL - value of the PATIENT ENROLLMENT object attribute named by SUB
;Output:
; Function Value - returns the external value of the attribute as
; defined by the PATIENT ENROLLMENT file
;
Q:(($G(SUB)="")!($G(VAL)="")) ""
;
N FLD
S FLD=$$FIELD(SUB)
;
Q:(FLD="") ""
Q $$EXTERNAL^DILFD(27.11,FLD,"F",VAL)
;
FIELD(SUB) ;
;Description: given a subscript in the enrollment array, returns the
; corresponding field number
N FLD S FLD=""
D ;drops out of block once SUB is determined
.I SUB="APP" S FLD=.01 Q
.I SUB="DATE" S FLD=.1 Q
.I SUB="END" S FLD=.11 Q
.I SUB="DFN" S FLD=.02 Q
.I SUB="SOURCE" S FLD=.03 Q
.I SUB="STATUS" S FLD=.04 Q
.I SUB="REASON" S FLD=.05 Q
.I SUB="REMARKS" S FLD=25 Q
.I SUB="FACREC" S FLD=.06 Q
.I SUB="PRIORITY" S FLD=.07 Q
.I SUB="EFFDATE" S FLD=.08 Q
.I SUB="PRIORREC" S FLD=.09 Q
.I SUB="SUBGRP" S FLD=.12 Q
.I SUB="RCODE" S FLD=.13 Q ;DJE field added with DG*5.3*940 - Closed Application - RM#867186
.;DG*5.3*993 Four new fields for decoupling
.I SUB="PTAPPLIED" S FLD=.14 Q
.I SUB="REGREA" S FLD=.15 Q
.I SUB="REGDATE" S FLD=.16 Q
.I SUB="REGSRC" S FLD=.17 Q
.;End of DG*5.3*993 mods
.I SUB="CODE" S FLD=50.01 Q
.I SUB="SC" S FLD=50.02 Q
.I SUB="SCPER" S FLD=50.03 Q
.I SUB="POW" S FLD=50.04 Q
.I SUB="A&A" S FLD=50.05 Q
.I SUB="HB" S FLD=50.06 Q
.I SUB="VAPEN" S FLD=50.07 Q
.I SUB="VACKAMT" S FLD=50.08 Q
.I SUB="DISRET" S FLD=50.09 Q
.I SUB="DISLOD" S FLD=50.2 Q ;field added with DG*5.3*672
.I SUB="MEDICAID" S FLD=50.1 Q
.I SUB="AO" S FLD=50.11 Q
.I SUB="AOEXPLOC" S FLD=50.22 Q ;field added with DG*5.3*688
.I SUB="IR" S FLD=50.12 Q
.I SUB="EC" S FLD=50.13 Q ;name now SW Asia Con, was Env Con DG*5.3*688
.I SUB="MTSTA" S FLD=50.14 Q
.I SUB="VCD" S FLD=50.15 Q
.I SUB="PH" S FLD=50.16 Q
.I SUB="UNEMPLOY" S FLD=50.17 Q
.I SUB="CVELEDT" S FLD=50.18 Q
.I SUB="SHAD" S FLD=50.19 Q ;field added with DG*5.3*653
.I SUB="MOH" S FLD=50.23 Q
.I SUB="CLE" S FLD=50.24 Q ;field added with DG*5.3*909
.I SUB="CLEDT" S FLD=50.25 Q ;field added with DG*5.3*909
.I SUB="CLEST" S FLD=50.26 Q ;field added with DG*5.3*909
.I SUB="CLESOR" S FLD=50.27 Q ;field added with DG*5.3*909
.I SUB="MOHAWRDDATE" S FLD=50.28 Q ;field added with DG*5.3*972 HM
.I SUB="MOHSTATDATE" S FLD=50.29 Q ;field added with DG*5.3*972 HM
.I SUB="MOHEXEMPDATE" S FLD=50.3 Q ;field added with DG*5.3*972 HM
.I SUB="OTHTYPE" S FLD=50.31 Q ; DG*5.3*952
.I SUB="DATETIME" S FLD=75.01 Q
.I SUB="USER" S FLD=75.02 Q
.I SUB="RADEXPM" S FLD=76 Q
Q FLD
;
PROMPT(FILE,FIELD,DEFAULT,RESPONSE,REQUIRE,PRMPTNM) ;
;Description: requests user to enter a single field value.
;Input:
; FILE - the file #
; FIELD - the field #
; DEFAULT - default value, internal form
; REQUIRE - a flag, (+value)'=0 means to require a value to be
; entered and to return failure otherwise (optional)
; PRMPTNM - Optional
; 0 - display field LABEL
; 1 - Prompt field TITLE
;Output:
; Function Value - 0 on failure, 1 on success
; RESPONSE - value entered by user, pass by reference
;
Q:(('$G(FILE))!('$G(FIELD))) 0
S REQUIRE=$G(REQUIRE)
S PRMPTNM=$G(PRMPTNM)
N DIR,DA,QUIT,AGAIN
;
S DIR(0)=FILE_","_FIELD_$S($G(REQUIRE):"",1:"O")_"AO"
I $G(DEFAULT)'="" DO
. S:+$G(PRMPTNM)=0 DIR("A")=$$GET1^DID(FILE,FIELD,"","LABEL")_": "_$$EXTERNAL^DILFD(FILE,FIELD,"F",DEFAULT)_"// "
. S:+$G(PRMPTNM)>0 DIR("A")=$$GET1^DID(FILE,FIELD,"","TITLE")_": "_$$EXTERNAL^DILFD(FILE,FIELD,"F",DEFAULT)_"// "
S QUIT=0
F D Q:QUIT
. D ^DIR
. I $D(DTOUT)!$D(DUOUT) S QUIT=1 Q
. I X="@" D Q:AGAIN
. . S AGAIN=0
. . I 'REQUIRE,"Yy"'[$E($$YN^DGENCD1(" Are you sure")_"X") S AGAIN=1 Q
. . S RESPONSE="" ; This might trigger the "required" message below.
. E I X="" S RESPONSE=$G(DEFAULT)
. E S RESPONSE=$P(Y,"^")
. ;
. ; quit this loop if the user entered value OR value not required
. I RESPONSE'="" S QUIT=1 Q
. I 'REQUIRE S QUIT=1 Q
. W !,"This is a required response. Enter '^' to exit"
I $D(DTOUT)!$D(DUOUT) Q 0
Q 1
;
INST(VADUZ,VACHK) ;
; Description: Determine the institution affiliation associated with a
; user.
;
; Input:
; VADUZ = array if passed by reference:
; VADUZ = DUZ
; VADUZ(2) =
; o if this value is null: DUZ(2) (institution affiliated
; with user, prompted at Kernel sign-on)
; o if value is not null: site to check as valid for the
; user (Pointer to INSTITUTION (#4) file)
; Output:
; Function Value - Returns pointer to the INSTITUTION (#4) file
; entry that is associated with the user, otherwise the pointer
; to the INSTITUTION (#4) file entry of the primary VA Medical
; Center division is returned.
;
; VACHK = passed by reference, returned as:
; null if the value in VADUZ(2) is null
; 0 if the value in VADUZ(2) is not null and is not a valid
; site for the user
; 1 if the value in VADUZ(2) is not null and is a valid site
; for the user
;
S VACHK=$S($G(VADUZ(2))="":"",1:0)
I $G(VADUZ(2)) D
. N X,ZZ
. Q:'$G(VADUZ)
. S X=$$DIV4^XUSER(.ZZ,VADUZ)
. I X,$D(ZZ(VADUZ(2))) S VACHK=1
I '$G(VADUZ(2)) S VADUZ(2)=$G(DUZ(2))
Q $S($G(VADUZ(2)):VADUZ(2),1:$P($$SITE^VASITE(),"^"))
;
GETINST(DGPREFAC,DGINST) ;Get Institution file data
; Input -- DGPREFAC Institution file IEN
; Output -- 1=Successful and 0=Failure
; DGINST - Institution file Array
N DGINST0,DGINST99,DGOKF
S DGINST0=$G(^DIC(4,DGPREFAC,0)) G GETQ:DGINST0=""
S DGINST("NAME")=$P(DGINST0,U)
S DGINST99=$G(^DIC(4,DGPREFAC,99))
S DGINST("STANUM")=$P(DGINST99,U)
S DGOKF=1
GETQ Q +$G(DGOKF)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGENU 9280 printed Apr 09, 2024@21:53:05 Page 2
DGENU ;ALB/CJM,ISA/KWP,Zoltan,LBD,EG,CKN,ERC,TMK,PWC,TDM,JLS,HM - Enrollment Utilities ;04/24/2006 9:20 AM
+1 ;;5.3;Registration;**121,122,147,232,314,564,624,672,659,653,688,536,838,841,909,940,972,952,993**;Aug 13,1993;Build 92
+2 ;
DISPLAY(DFN) ;
+1 ;Description: Display status message, current enrollment and
+2 ; preferred facility information
+3 ;Input:
+4 ; DFN - Patient IEN
+5 ; Output: none
+6 ;
+7 NEW STATUS
+8 SET STATUS=$$STATUS^DGENA(DFN)
+9 IF 'STATUS
WRITE !!,"Patient is NOT enrolled in the VA Patient Enrollment System..."
+10 IF '$TEST
IF STATUS=2
Begin DoDot:1
+11 WRITE !!,"Patient is enrolled in the VA Patient Enrollment System..."
End DoDot:1
+12 ; Purple Heart added status 21
+13 IF '$TEST
IF (STATUS=9)!(STATUS=1)!(STATUS=15)!(STATUS=16)!(STATUS=17)!(STATUS=18)!(STATUS=21)
Begin DoDot:1
+14 WRITE !!,"Application is pending for enrollment in the VA Patient Enrollment System..."
End DoDot:1
+15 IF '$TEST
Begin DoDot:1
+16 WRITE !!,"Patient is NOT enrolled in the VA Patient Enrollment System..."
End DoDot:1
+17 DO CUR(DFN)
+18 QUIT
+19 ;
CUR(DFN) ;
+1 ;Description - displays current enrollment, category, enrollment
+2 ; group threshold, preferred facility and source designation
+3 ;
+4 NEW FACNAME,PREFAC,PFSRC,DGEGT,DGEGTIEN,DGENCAT,DGENR,IORVON,IORVOFF
+5 IF $$GET^DGENA($$FINDCUR^DGENA(DFN),.DGENR)
+6 ;Get enrollment category
+7 SET DGENCAT=$$CATEGORY^DGENA4(DFN)
+8 ;Display Category in reverse video
+9 DO REV
+10 ;Get enrollment group threshold
+11 SET DGEGTIEN=$$FINDCUR^DGENEGT
+12 SET DGEGT=$$GET^DGENEGT(DGEGTIEN,.DGEGT)
+13 ;Preferred facility
+14 SET PREFAC=$$PREF^DGENPTA(DFN,.FACNAME)
+15 ;Source Designation
+16 SET PFSRC=$$GET1^DIQ(2,DFN_",",27.03)
+17 WRITE !?3,"Enrollment Date",?35,": ",$SELECT('$GET(DGENR("DATE")):"-none-",1:$$EXT^DGENU("DATE",DGENR("DATE")))
+18 WRITE !?3,"Application Date",?35,": ",$SELECT('$GET(DGENR("APP")):"-none-",1:$$EXT^DGENU("DATE",DGENR("APP")))
+19 WRITE !?3,IORVON,"Enrollment Category : ",$SELECT($GET(DGENCAT)="":"-none-",1:$$EXTERNAL^DILFD(27.15,.02,"",DGENCAT)),IORVOFF
+20 WRITE !?3,"Enrollment Status",?35,": ",$SELECT($GET(DGENR("STATUS"))="":"-none-",1:$$EXT^DGENU("STATUS",DGENR("STATUS")))
+21 WRITE !?3,"Enrollment Priority",?35,": ",$SELECT($GET(DGENR("PRIORITY"))="":"-none-",1:DGENR("PRIORITY")),$SELECT($GET(DGENR("SUBGRP"))="":"",1:$$EXT("SUBGRP",DGENR("SUBGRP")))
+22 WRITE !?3,"Preferred Facility",?35,": ",$SELECT($GET(FACNAME)'="":FACNAME,1:"-none-")
+23 WRITE !?3,"Preferred Facility Source",?35,": ",$SELECT($GET(PFSRC)'="":PFSRC,1:"-none-")
+24 WRITE !?3,"Enrollment Group Threshold",?35,": ",$SELECT($GET(DGEGT("PRIORITY"))="":"-none-",1:$$EXTERNAL^DILFD(27.16,.02,"",$GET(DGEGT("PRIORITY")))),$SELECT($GET(DGEGT("SUBGRP"))="":"",1:$$EXTERNAL^DILFD(27.16,.03,"",$GET(DGEGT("SUBGRP"))))
+25 WRITE !
+26 QUIT
REV ;Get variables to display text in reverse video
+1 NEW X
+2 SET X="IORVON;IORVOFF"
+3 DO ENDR^%ZISS
+4 QUIT
PATID(DFN) ;
+1 ;Description - Called by FileMan as an identifier for the Patient file.
+2 ;Displays current enrollment status, priority, and preferred facility.
+3 ;
+4 ;Input:
+5 ; DFN - ien to Patient file
+6 ;
+7 NEW PREFAC,DGENR,OUTPUT
+8 IF '$$GET^DGENA($$FINDCUR^DGENA(DFN),.DGENR)
Begin DoDot:1
+9 SET OUTPUT="NO ENROLLMENT APPLICATION ON FILE "
End DoDot:1
+10 IF '$TEST
Begin DoDot:1
+11 SET OUTPUT=$EXTRACT("PRIORITY:"_DGENR("PRIORITY")_" ",1,12)_$EXTRACT("STATUS:"_$$EXT^DGENU("STATUS",DGENR("STATUS"))_" ",1,26)
End DoDot:1
+12 SET PREFAC=$$PREF^DGENPTA(DFN)
+13 if PREFAC
SET OUTPUT=OUTPUT_"PREFERRED FACILITY:"_$PIECE($GET(^DIC(4,PREFAC,99)),"^")
+14 IF $GET(IOM)
IF ($X#$GET(IOM))<6
Begin DoDot:1
+15 DO EN^DDIOL(OUTPUT,,"?($X+(10-($X#IOM)))")
End DoDot:1
+16 IF '$TEST
Begin DoDot:1
+17 DO EN^DDIOL(OUTPUT,,"!?10")
End DoDot:1
+18 QUIT
+19 ;
EXT(SUB,VAL) ;
+1 ;Description: Given the subscript used in the PATIENT ENROLLMENT array,
+2 ; and a field value, returns the external representation of the
+3 ; value, as defined in the fields output transform of the PATIENT
+4 ; ENROLLMENT file.
+5 ;Input:
+6 ; SUB - subscript in the array defined by the PATIENT ENROLLMENT object
+7 ; VAL - value of the PATIENT ENROLLMENT object attribute named by SUB
+8 ;Output:
+9 ; Function Value - returns the external value of the attribute as
+10 ; defined by the PATIENT ENROLLMENT file
+11 ;
+12 if (($GET(SUB)="")!($GET(VAL)=""))
QUIT ""
+13 ;
+14 NEW FLD
+15 SET FLD=$$FIELD(SUB)
+16 ;
+17 if (FLD="")
QUIT ""
+18 QUIT $$EXTERNAL^DILFD(27.11,FLD,"F",VAL)
+19 ;
FIELD(SUB) ;
+1 ;Description: given a subscript in the enrollment array, returns the
+2 ; corresponding field number
+3 NEW FLD
SET FLD=""
+4 ;drops out of block once SUB is determined
Begin DoDot:1
+5 IF SUB="APP"
SET FLD=.01
QUIT
+6 IF SUB="DATE"
SET FLD=.1
QUIT
+7 IF SUB="END"
SET FLD=.11
QUIT
+8 IF SUB="DFN"
SET FLD=.02
QUIT
+9 IF SUB="SOURCE"
SET FLD=.03
QUIT
+10 IF SUB="STATUS"
SET FLD=.04
QUIT
+11 IF SUB="REASON"
SET FLD=.05
QUIT
+12 IF SUB="REMARKS"
SET FLD=25
QUIT
+13 IF SUB="FACREC"
SET FLD=.06
QUIT
+14 IF SUB="PRIORITY"
SET FLD=.07
QUIT
+15 IF SUB="EFFDATE"
SET FLD=.08
QUIT
+16 IF SUB="PRIORREC"
SET FLD=.09
QUIT
+17 IF SUB="SUBGRP"
SET FLD=.12
QUIT
+18 ;DJE field added with DG*5.3*940 - Closed Application - RM#867186
IF SUB="RCODE"
SET FLD=.13
QUIT
+19 ;DG*5.3*993 Four new fields for decoupling
+20 IF SUB="PTAPPLIED"
SET FLD=.14
QUIT
+21 IF SUB="REGREA"
SET FLD=.15
QUIT
+22 IF SUB="REGDATE"
SET FLD=.16
QUIT
+23 IF SUB="REGSRC"
SET FLD=.17
QUIT
+24 ;End of DG*5.3*993 mods
+25 IF SUB="CODE"
SET FLD=50.01
QUIT
+26 IF SUB="SC"
SET FLD=50.02
QUIT
+27 IF SUB="SCPER"
SET FLD=50.03
QUIT
+28 IF SUB="POW"
SET FLD=50.04
QUIT
+29 IF SUB="A&A"
SET FLD=50.05
QUIT
+30 IF SUB="HB"
SET FLD=50.06
QUIT
+31 IF SUB="VAPEN"
SET FLD=50.07
QUIT
+32 IF SUB="VACKAMT"
SET FLD=50.08
QUIT
+33 IF SUB="DISRET"
SET FLD=50.09
QUIT
+34 ;field added with DG*5.3*672
IF SUB="DISLOD"
SET FLD=50.2
QUIT
+35 IF SUB="MEDICAID"
SET FLD=50.1
QUIT
+36 IF SUB="AO"
SET FLD=50.11
QUIT
+37 ;field added with DG*5.3*688
IF SUB="AOEXPLOC"
SET FLD=50.22
QUIT
+38 IF SUB="IR"
SET FLD=50.12
QUIT
+39 ;name now SW Asia Con, was Env Con DG*5.3*688
IF SUB="EC"
SET FLD=50.13
QUIT
+40 IF SUB="MTSTA"
SET FLD=50.14
QUIT
+41 IF SUB="VCD"
SET FLD=50.15
QUIT
+42 IF SUB="PH"
SET FLD=50.16
QUIT
+43 IF SUB="UNEMPLOY"
SET FLD=50.17
QUIT
+44 IF SUB="CVELEDT"
SET FLD=50.18
QUIT
+45 ;field added with DG*5.3*653
IF SUB="SHAD"
SET FLD=50.19
QUIT
+46 IF SUB="MOH"
SET FLD=50.23
QUIT
+47 ;field added with DG*5.3*909
IF SUB="CLE"
SET FLD=50.24
QUIT
+48 ;field added with DG*5.3*909
IF SUB="CLEDT"
SET FLD=50.25
QUIT
+49 ;field added with DG*5.3*909
IF SUB="CLEST"
SET FLD=50.26
QUIT
+50 ;field added with DG*5.3*909
IF SUB="CLESOR"
SET FLD=50.27
QUIT
+51 ;field added with DG*5.3*972 HM
IF SUB="MOHAWRDDATE"
SET FLD=50.28
QUIT
+52 ;field added with DG*5.3*972 HM
IF SUB="MOHSTATDATE"
SET FLD=50.29
QUIT
+53 ;field added with DG*5.3*972 HM
IF SUB="MOHEXEMPDATE"
SET FLD=50.3
QUIT
+54 ; DG*5.3*952
IF SUB="OTHTYPE"
SET FLD=50.31
QUIT
+55 IF SUB="DATETIME"
SET FLD=75.01
QUIT
+56 IF SUB="USER"
SET FLD=75.02
QUIT
+57 IF SUB="RADEXPM"
SET FLD=76
QUIT
End DoDot:1
+58 QUIT FLD
+59 ;
PROMPT(FILE,FIELD,DEFAULT,RESPONSE,REQUIRE,PRMPTNM) ;
+1 ;Description: requests user to enter a single field value.
+2 ;Input:
+3 ; FILE - the file #
+4 ; FIELD - the field #
+5 ; DEFAULT - default value, internal form
+6 ; REQUIRE - a flag, (+value)'=0 means to require a value to be
+7 ; entered and to return failure otherwise (optional)
+8 ; PRMPTNM - Optional
+9 ; 0 - display field LABEL
+10 ; 1 - Prompt field TITLE
+11 ;Output:
+12 ; Function Value - 0 on failure, 1 on success
+13 ; RESPONSE - value entered by user, pass by reference
+14 ;
+15 if (('$GET(FILE))!('$GET(FIELD)))
QUIT 0
+16 SET REQUIRE=$GET(REQUIRE)
+17 SET PRMPTNM=$GET(PRMPTNM)
+18 NEW DIR,DA,QUIT,AGAIN
+19 ;
+20 SET DIR(0)=FILE_","_FIELD_$SELECT($GET(REQUIRE):"",1:"O")_"AO"
+21 IF $GET(DEFAULT)'=""
Begin DoDot:1
+22 if +$GET(PRMPTNM)=0
SET DIR("A")=$$GET1^DID(FILE,FIELD,"","LABEL")_": "_$$EXTERNAL^DILFD(FILE,FIELD,"F",DEFAULT)_"// "
+23 if +$GET(PRMPTNM)>0
SET DIR("A")=$$GET1^DID(FILE,FIELD,"","TITLE")_": "_$$EXTERNAL^DILFD(FILE,FIELD,"F",DEFAULT)_"// "
End DoDot:1
+24 SET QUIT=0
+25 FOR
Begin DoDot:1
+26 DO ^DIR
+27 IF $DATA(DTOUT)!$DATA(DUOUT)
SET QUIT=1
QUIT
+28 IF X="@"
Begin DoDot:2
+29 SET AGAIN=0
+30 IF 'REQUIRE
IF "Yy"'[$EXTRACT($$YN^DGENCD1(" Are you sure")_"X")
SET AGAIN=1
QUIT
+31 ; This might trigger the "required" message below.
SET RESPONSE=""
End DoDot:2
if AGAIN
QUIT
+32 IF '$TEST
IF X=""
SET RESPONSE=$GET(DEFAULT)
+33 IF '$TEST
SET RESPONSE=$PIECE(Y,"^")
+34 ;
+35 ; quit this loop if the user entered value OR value not required
+36 IF RESPONSE'=""
SET QUIT=1
QUIT
+37 IF 'REQUIRE
SET QUIT=1
QUIT
+38 WRITE !,"This is a required response. Enter '^' to exit"
End DoDot:1
if QUIT
QUIT
+39 IF $DATA(DTOUT)!$DATA(DUOUT)
QUIT 0
+40 QUIT 1
+41 ;
INST(VADUZ,VACHK) ;
+1 ; Description: Determine the institution affiliation associated with a
+2 ; user.
+3 ;
+4 ; Input:
+5 ; VADUZ = array if passed by reference:
+6 ; VADUZ = DUZ
+7 ; VADUZ(2) =
+8 ; o if this value is null: DUZ(2) (institution affiliated
+9 ; with user, prompted at Kernel sign-on)
+10 ; o if value is not null: site to check as valid for the
+11 ; user (Pointer to INSTITUTION (#4) file)
+12 ; Output:
+13 ; Function Value - Returns pointer to the INSTITUTION (#4) file
+14 ; entry that is associated with the user, otherwise the pointer
+15 ; to the INSTITUTION (#4) file entry of the primary VA Medical
+16 ; Center division is returned.
+17 ;
+18 ; VACHK = passed by reference, returned as:
+19 ; null if the value in VADUZ(2) is null
+20 ; 0 if the value in VADUZ(2) is not null and is not a valid
+21 ; site for the user
+22 ; 1 if the value in VADUZ(2) is not null and is a valid site
+23 ; for the user
+24 ;
+25 SET VACHK=$SELECT($GET(VADUZ(2))="":"",1:0)
+26 IF $GET(VADUZ(2))
Begin DoDot:1
+27 NEW X,ZZ
+28 if '$GET(VADUZ)
QUIT
+29 SET X=$$DIV4^XUSER(.ZZ,VADUZ)
+30 IF X
IF $DATA(ZZ(VADUZ(2)))
SET VACHK=1
End DoDot:1
+31 IF '$GET(VADUZ(2))
SET VADUZ(2)=$GET(DUZ(2))
+32 QUIT $SELECT($GET(VADUZ(2)):VADUZ(2),1:$PIECE($$SITE^VASITE(),"^"))
+33 ;
GETINST(DGPREFAC,DGINST) ;Get Institution file data
+1 ; Input -- DGPREFAC Institution file IEN
+2 ; Output -- 1=Successful and 0=Failure
+3 ; DGINST - Institution file Array
+4 NEW DGINST0,DGINST99,DGOKF
+5 SET DGINST0=$GET(^DIC(4,DGPREFAC,0))
if DGINST0=""
GOTO GETQ
+6 SET DGINST("NAME")=$PIECE(DGINST0,U)
+7 SET DGINST99=$GET(^DIC(4,DGPREFAC,99))
+8 SET DGINST("STANUM")=$PIECE(DGINST99,U)
+9 SET DGOKF=1
GETQ QUIT +$GET(DGOKF)
