source: FOIAVistA/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGENU.m@ 794

DGENU ;ALB/CJM,ISA/KWP,Zoltan,LBD,EG,CKN - Enrollment Utilities; 04/24/2006 9:20 AM
 ;;5.3;Registration;**121,122,147,232,314,564,624,672,659,653**;Aug 13,1993;Build 2
 ;
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, and preferred facility
 ;
 N FACNAME,PREFAC,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)
 W !?3,"Enrollment Date",?35,": ",$S('$G(DGENR("DATE")):"-none-",1:$$EXT^DGENU("DATE",DGENR("DATE")))
 W !?3,"Enrollment 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,"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="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="IR" S FLD=50.12 Q
 .I SUB="EC" S FLD=50.13 Q
 .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="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() ;
 ; Description: Determine the institution affiliation associated with a user.
 ;
 ;  Input:
 ;     DUZ(2) - Pointer to the INSTITUTION (#4) file (institution
 ;              affiliated with user, prompted at Kernel sign-on)
 ;
 ; 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.
 ;
 Q $S($G(DUZ(2)):DUZ(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)