- 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 Jan 18, 2025@03:43:54 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)