Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Info |  Source |  Entry Points |  Interaction Calls |  FileMan Files Accessed Via FileMan Db Call
Print Page as PDF
Routine: DGRPE

Package: Registration

Routine: DGRPE


Information

DGRPE ;ALB/MRL,LBD,BRM,TMK,BAJ,PWC,JAM,JAM,JAM,LEG,ARF - REGISTRATIONS EDITS ;23 May 2017 1:51 PM

Source Information

Source file <DGRPE.m>

Entry Points

Name Comments DBIA/ICR reference
Q
SETDR(DGDR,DR) ; Set up DR string(s) for edit groups selected
S
SETFLDS(DGDR) ; Set up fields to edit
101 ;;
102 ;;1;
103 ;;.091;
; DG*5.3*1111 - PAGER moved to DR104^DGRPE1, Email Address Indicator moved to YN1316^DGRPE1
; Handle timeout/exits from either field edit
104 ;;.134;I '$$DR104^DGRPE1 S Y="@99";@21;S X=$$YN1316^DGRPE1(DFN) I +$G(DGTMOT) S Y="@99";S:(X["N")&($P($G(^DPT(DFN,.13)),"^",3)="") Y="@25";S:(X["N")&($P($G(^DPT(DFN,.13)),"^",3)]"") Y="@24";
104000 ;;.133;S:($P($G(^DPT(DFN,.13)),U,16)="Y")&($G(X)="") Y="@21";S Y="@25";@24;.133///@;@25;.1317///NOW;@99;
105 ;;D DR207^DGRPE1;
106 ;;.2405;
108 ;;N FLG S (FLG(1),FLG(2))=1 D EN^DGREGAED(DFN,.FLG);
109 ;;N FLG S (FLG(1),FLG(2))=1 D EN^DGREGAED(DFN,.FLG);.02;D DR207^DGRPE;7LANGUAGE DATE/TIME;D LANGDEL^DGRPE;D DR109^DGRPE;6;2;K DR(2,2.02),DR(2,2.06);.05;.08;K DIE("NO^");
; DG*5.3*1040 - If no timeout from previous field then proceed to next prompt
111 ;;N FLG S (FLG(1),FLG(2))=1 D EN^DGREGRED(DFN,.FLG);D:'+$G(DGTMOT) RESMVQ^DGREGCP1(DFN);
112 ;;S:$G(^DPT(DFN,.11))'="" Y="@30";D DR11^DGRPE S:$G(^DPT(DFN,.11))'="" Y="@31";
; DG*5.3*1040 - If no timeout from previous field then proceed to next prompt
112000 ;;@30;N FLG S FLG(1)=0,FLG(2)=1 D EN^DGREGAED(DFN,.FLG) D:'+$G(DGTMOT) PERMMVQ^DGREGCP1(DFN);@31;
113 ;;.12105TEMP MAILING ADDRESS ACTIVE;S:X="N" Y="@15";S DIE("NO^")="";.1217TEMP MAILING ADDRESS START DATE;.1218TEMP MAILING ADDRESS END DATE;N RET S RET=1 D EN^DGREGTED(DFN,"TEMP",.RET) S:'RET&('+$G(DGTMOT)) Y=.12105;@15;K DIE("NO^");
114 ;;.14105//NO;S:X="N" Y="@111" S:X="Y" DIE("NO^")="";.1417;I X']"" W !?4,$C(7),"But I need a Start Date." S Y=.14105;.1418;D DR111^DGRPE;.141;I '$P($$CAACT^DGRPCADD(DFN),U,2) W !?4,"But I need at least one active category." S Y=.14105;
; DG*5.3*1014;jam; add K ^DIE("NO^") after enty of confidential address so if we loop back to beginning, we can exit
; DG*5.3*1040 - Add check for variable DGTMOT
114000 ;;K DR(2,2.141);N RET S RET=1 D EN^DGREGTED(DFN,"CONF",.RET) K DIE("NO^") S:'RET&('+$G(DGTMOT)) Y=.14105;@111;K DIE("NO^");
201 ;;.05;.08;.092;.093;.2403;57.4//NOT APPLICABLE;
202 ;;1010.15//NO;S:X'="Y" Y="@22";S DIE("NO^")="";1010.152;I X']"" W !?4,*7,"But I need to know where you were treated most recently." S Y=1010.15;1010.151;1010.154;S:X']"" Y="@22";1010.153;@22;K DIE("NO^");
203 ;;D DR203^DGRPE;6ETHNICITY;2RACE;K DR(2,2.02),DR(2,2.06);
205 ;;.181;
; patch DG*5.3*1064; ARF; added group 6 to the PATIENT DATA, SCREEN <2>
206 ;;D DR206^DGRPE;
; patch DG*5.3*985 - NOK - Tags 301 and 302 for Primary and Secondary NOK: phone number no longer copied when copying patient address - phone number entered on its own
; patch DG*5.3*997; jam; Tags 301-305 modified to allow for copy or entry of Country/foreign addresses
301 ;;.211;S:X']"" Y="@31";N RET S RET=$$DR300^DGRP3("K",.224,.212) I $G(DGTMOT)=1!('RET) S Y="@31";.2125//NO;I X="Y" S DGADD=".21" D AD^DGRPE S Y="@30";.221//USA;.213;S:X']"" Y=.216;.214;S:X']"" Y=.216;.215;.216;
301000 ;;S DGADD=".21" D DR301^DGRPE S:DG4=1 Y=.222;.217;.2207;S Y="@30";.222;.223;@30;K DG4;.219;.21011;@31;
302 ;;.2191;S:X']"" Y="@32";N RET S RET=$$DR300^DGRP3("K2",.2104,.2192) I $G(DGTMOT)=1!('RET) S Y="@32";.21925//NO;I X="Y" S DGADD=".211" D AD^DGRPE S Y="@301";
302000 ;;.2101//USA;.2193;S:X']"" Y=.2196;.2194;S:X']"" Y=.2196;.2195;.2196;S DGADD=".211" D DR301^DGRPE S:DG4=1 Y=.2102;.2197;.2203;S Y="@301";.2102;.2103;@301;K DG4;.2199;.211011;@32;
303 ;;N DGX1,DGX2;I '$L($P($G(^DPT(DFN,.21)),U)) S Y="@33";.3305//NO;I X="Y" S Y="@34",DGX1=1 S:$D(^DPT(DFN,.22)) $P(^(.22),U,1)=$P(^(.22),U,7);@33;.331;S:X']"" DGX1=2,Y="@34";
303000 ;;N RET S RET=$$DR300^DGRP3("E",.3309,.332) I $G(DGTMOT)=1!('RET) S Y="@351";@34;
303001 ;;S:$G(DGX1) Y="@341";.3306//USA;.333;S:X']"" Y=.336;.334;S:X']"" Y=.336;.335;.336; S DGADD=".33" D DR301^DGRPE S:DG4=1 Y=.3307;.337;.2201;S Y="@361";.3307;.3308;@361;K DG4;.339;.33011;S DGX1=2;@341;
303002 ;;S:$G(DGX1)=2 Y="@35";S DGX2=$G(^DPT(DA,.21));.331///^S X=$P(DGX2,U);.332///^S X=$P(DGX2,U,2);.333////^S X=$P(DGX2,U,3);.334///^S X=$P(DGX2,U,4);.3306///^S X=$P(DGX2,U,12);.3307///^S X=$P(DGX2,U,13);.3308///^S X=$P(DGX2,U,14);@35;
303003 ;;S:$G(DGX1)=2 Y="@351";.335///^S X=$P(DGX2,U,5);.336///^S X=$P(DGX2,U,6);.337///^S X=$P(DGX2,U,7);.338///^S X=$P(DGX2,U,8);.339///^S X=$P(DGX2,U,9);.33011///^S X=$P(DGX2,U,11);.3309///^S X=$P(DGX2,U,15);@351;K DGX1,DGX2;
304 ;;.3311;S:X']"" Y="@36";N RET S RET=$$DR300^DGRP3("E2",.331015,.3312) I $G(DGTMOT)=1!('RET) S Y="@36";.331012//USA;.3313;S:X']"" Y=.3316;.3314;S:X']"" Y=.3316;.3315;.3316; S DGADD=".331" D DR301^DGRPE S:DG4=1 Y=.331013;.3317;
304000 ;;.2204;S Y="@37";.331013;.331014;@37;K DG4;.3319;.331011;@36;
305 ;;N DGX1,DGX2;I '$L($P($G(^DPT(DFN,.21)),U)) S Y="@372";.3405//NO;I X="Y" S DGX1=1,Y="@371" S:$D(^DPT(DFN,.22)) $P(^(.22),U,2)=$P(^(.22),U,7);@372;.341;S:X']"" DGX1=2,Y="@371";
305000 ;;N RET S RET=$$DR300^DGRP3("D",.34015,.342) I $G(DGTMOT)=1!('RET) S Y="@39";@371;
305001 ;;S:$G(DGX1) Y="@38";.34012//USA;.343;S:X']"" Y=.346;.344;S:X']"" Y=.346;.345;.346; S DGADD=".34" D DR301^DGRPE S:DG4=1 Y=.34013;.347;.2202;S Y="@391";.34013;.34014;@391;K DG4;.349;.34011;S DGX1=2;@38;
305002 ;;S:$G(DGX1)=2 Y="@381";S DGX2=$G(^DPT(DA,.21));.341///^S X=$P(DGX2,U);.342///^S X=$P(DGX2,U,2);.343///^S X=$P(DGX2,U,3);.344///^S X=$P(DGX2,U,4);.34012///^S X=$P(DGX2,U,12);.34013///^S X=$P(DGX2,U,13);.34014///^S X=$P(DGX2,U,14);@381
305003 ;;S:$G(DGX1)=2 Y="@39";.345///^S X=$P(DGX2,U,5);.346///^S X=$P(DGX2,U,6);.347///^S X=$P(DGX2,U,7);.348///^S X=$P(DGX2,U,8);.349///^S X=$P(DGX2,U,9);.34011///^S X=$P(DGX2,U,11);.34015///^S X=$P(DGX2,U,15);@39;K DGX1,DGX2;
401 ;;.01;.31115;S:($S(X']"":1,X=3:1,X=9:1,1:0)) Y="@41" S:(X'=5) Y=.3111;.31116;.3111;S:X']"" Y="@41";.3113;S:X']"" Y=.3116;.3114;S:X']"" Y=.3116;.3115:.3117;.2205;.3119;@41;
402 ;;.2514;.2515;S:($S(X']"":1,X=3:1,X=9:1,1:0)) Y="@42" S:(X'=5) Y=.251;.2516;.251;S:X']"" Y="@42";.252;S:X']"" Y=.255;.253;S:X']"" Y=.255;.254:.256;.2206;.258;@42;
501 ;;
502 ;;.381;.382///NOW;
503 ;;.383;
601 ;;Q;
602 ;;Q;
603 ;;Q;
604 ;;.525//NO;S:X'="Y" Y="@62";.526:.528;@62;
605 ;;.5291//NO;S:X'="Y" Y="@63";.5292:.5294;@63;
606 ;;I $P($G(^DPT(DFN,.361)),U,3)="H" S Y="@6131";.3602//NO;.3603//NO;S Y="@6132";@6131;.3602;.3603;@6132;
607 ;;.368//NO;.369//NO;I $S('$D(^DPT(DA,.36)):1,$P(^(.36),U,8)="Y"!($P(^(.36),U,9)="Y"):0,1:1) S Y="@614";.37;@614;
608 ;;S DGPHFLG=0;.531;S:X'="Y" DGX=X,Y="@616";.532///^S X="PENDING";S Y="@6161";@616;S:DGX'="N" Y="@6162";.533///^S X="VAMC";@6161;S DGPHFLG=1;.535///^S X=$$DIV^DGRPLE();@6162;
AD ; DG*5.3*1014;jam; Replace code below - store data via Fileman and not direct global sets
; Input: DGADD =.21 for copying to NOK
; =.211 for copying to NOK2
DR109 ;Drop through (use same logic as DR203)
DR203
DR11 ;clt; DG*5.3*941 - Called from line tag 112 if Perm address is empty
DR111 ; Set DR string for Confidential Address categories
DR206 ;DG*5.3*1064; Code for group 6 on screen 2
REENTER ;NULL attestation date is not allowed - redisplay prompt
CONFIRM() ;Confirm if user wants to save the changes - DG*5.3*1064
EOP ;DG*5.3*1064
DR207 ; DR string for preferred language ;*///*
DR301 ; jam; DG*5.3*997 - check for foreign address
PRF ; Write Proof needed for FV
SET32(DA,DIPA,SEQ) ; Extract the .32 node from patient file and set DIPA
; array with the BOS and component data for the SEQ military service
; episode (1-3)
WARN32(X,DIPA,SEQ,Y) ; Warn if the BOS is changed, then the component will
; be deleted
; Returns Y to skip component if the component should not be asked
; for this branch of service
CMP(X) ; Function to determine if service component is valid for
; branch of service ien in X 0 = invalid 1 = valid
; Component only valid for ARMY/AIR FORCE/MARINES/COAST GUARD/NOAA/USPHS/SPACE FORCE
INPXF207 ; Input transform for field 7 in file ;*///*
XHELP207 ; This is a screen to be sure the language is a 'living' language, i.e.in use today and that it has the required 2-character code. ;*///*
LANGDEL ; If no language entered, remove the stub record ;*///*
  • ICR #6405
    • Status: Active
    • Usage: Private

    Interaction Calls

    Name Line Occurrences
    Function Call: WRITE
    • Prompt: !!,"**NOTE-Change(s) made in this session deleted the veteran's Combat Vet status!"
    • Line Location: DGRPE+44
    Function Call: WRITE
    • Prompt: !?4,"But I need at least one active category."
    • Line Location: 114+0
    Function Call: WRITE
    • Prompt: !,"The Patient has no Mailing Address."
    • Line Location: DR11+7
    Function Call: WRITE
    • Prompt: !,"This is a required response. Enter "_"'^'"_" to exit"
    • Line Location: REENTER+6
    Function Call: WRITE
    • Prompt: !,"Indian attestation not saved.",!
    • Line Location: REENTER+11
    Function Call: WRITE
    • Prompt: !,"Changes saved.",!
    • Line Location: REENTER+14
    Function Call: WRITE
    • Prompt: !?4,$C(7),"Proof is required for Filipino vet."
    • Line Location: PRF+1
    Function Call: WRITE
    • Prompt: !!,*7,"** WARNING - BRANCH OF SERVICE WAS CHANGED SO THE COMPONENT WAS DELETED",!
    • Line Location: WARN32+9

    FileMan Files Accessed Via FileMan Db Call

    FileNo Call Tags
    ^DI(.85 - [#.85] Classic Fileman Calls
    ^DPT - [#2] Classic Fileman Calls
    Info |  Source |  Entry Points |  Interaction Calls |  FileMan Files Accessed Via FileMan Db Call