DGRPV ;ALB/MRL,RTK,PJR,BRM,TMK,AMA,LBD,TDM,PWC,JAM,JAM,ASF,LEG,ARF,JAM - REGISTRATION DEFINE VARIABLES ON ENTRY ;Apr 05, 2020@19:00
;;5.3;Registration;**109,114,247,190,327,365,343,397,415,489,546,545,451,624,677,672,689,716,688,797,842,871,887,941,985,997,1014,1064,1081,1093**;Aug 13, 1993;Build 12
;
;
;set up variables for registration screen processing
;
;DGRPVV :string of 15 ones and zeros each character corresponding to
; a particular screen (0 means allow edit, 1 means don't)
;
;DGRPVV(n):where n=screen number. String of x ones and zeros where
; x is the number of elements on screen n (0=edit, 1=don't)
;
;DGVI :Turn on high intensity
;DGVO :Turn off high intensity
;
EN D DT^DICRW I '$D(DVBGUI) D HOME^%ZIS
S (DGVI,DGVO)="""""" I $S('$D(IOST(0)):1,'$D(^DG(43,1,0)):1,'$P(^DG(43,1,0),"^",36):1,$D(^DG(43,1,"TERM",IOST(0))):1,1:0) G M ;goto M if not high intensity
I $D(^%ZIS(2,IOST(0),7)) S I=^(7),X=$S($P(I,"^",3)]"":3,1:2) I $L($P(I,"^",1)),$L($P(I,"^",X)) S DGVI=$P(I,"^",1),DGVO=$P(I,"^",X)
M I $L(DGVI_DGVO)>4 S X=132 X ^%ZOSF("RM")
S DGRPW=1,DGRPCM=0,DGRPU="UNANSWERED",DGRPNA="NOT APPLICABLE",DGRPV=$S($D(DGRPV):DGRPV,1:1)
MSE ;Move MSE data from node .32 to .3216 multiple in Patient file #2
;DG*5.3*797
I '$D(^DPT(DFN,.3216)) D MOVMSE^DGMSEUTL(DFN)
SC7 S X=$S('$D(^DPT(DFN,"TYPE")):0,1:+^("TYPE")) S:'$D(DGELVER) DGELVER=0
S DGRPTYPE=$S($D(^DG(391,+X,0)):^(0),1:""),(DGRPSC,DGRPSCE,DGRPSCE1)="" S:'$D(DGELVER) DGELVER=0
I DGRPTYPE'="" S DGRPSC=$G(^DG(391,+X,"S")),DGRPSCE=$G(^("E")),DGRPSCE1=$G(^("E10"))
;
S DGPH=$P($G(^DPT(DFN,.53)),U) ;Purple Heart Indicator
I $G(DGPRFLG)=1 D
. S DGRPVV="000001111111111"
E D
. S DGRPVV="000000000000000"
; DG*5.3*985;JAM - Screen 1 now has 6 groups
S X="6^3^5^2^3^10^4^2^3^2^5^5^5^2^1"
F I=1:1:15 S J=+$P(X,"^",I),DGRPVV(I)=$S((I<12)!(I=15):$E("00000000000000000",1,J),1:$E("11111111111111111",1,J))
;JAM - patch DG*5.3*941 - Screen 1.1 reformat - 4 groups
S DGRPVV(1.1)="0000"
;ARF - patch DG*5.3*1064 - Add group 6 to PATIENT DATA, SCREEN <2>
; DG*5.3*1093 - Screen 2, Group 6 is made read-only
S DGRPVV(2)="000101"
;ARF - patch DG*5.3*1081 - Make group 1 not editable on the INELIGIBLE/MISSING DATA, SCREEN <10>
S DGRPVV(10)="10"
; DG*5.3*997; ASF; Allowing selection for screen 11.5, group 1 (allows user to see sub-screen 11.5.1)
S DGRPVV(11.5)="00" ;LEG ;DG*5.3.1014 ; added extra "0" for group [2] ;was S DGRPVV(11.5)=0
I $P($G(^DPT(DFN,.52)),U,9)'="" S $E(DGRPVV(6),4)=1 ;POW status verified, no editing (DG*5.3*688)
I $G(DGPH)]"" S $E(DGRPVV(6),8)=1
S $E(DGRPVV(6),9,10)="11"
;
F I=3,6,8,9,10,11 S J=+$P(DGRPSC,"^",I) I 'J S DGRPVV=$E(DGRPVV,0,I-1)_1_$E(DGRPVV,I+1,99)
;
;-- if patient type is TRICARE then turn off screens 2,4
;
;-- modified 08/20/2003 for NOIS Calls MAC-0400-61574 & AMA-0700-71769
;-- commented the line to allow screens 2 & 4 to display for Tricare
;I DGRPTYPE["TRICARE" F I=2,4 S J=+$P(DGRPSC,"^",I) I 'J S DGRPVV=$E(DGRPVV,0,I-1)_1_$E(DGRPVV,I+1,99)
;
F I=31:0 S I=$O(^DD(391,I)) Q:I=""!(I>99) I $D(^(I,0)),($E(^(0),1)'="*"),'+$P(DGRPSCE,"^",I) S X1=$E(I),X2=$E(I,2) I +X1 S DGRPVV(X1)=$E(DGRPVV(X1),0,X2-1)_1_$E(DGRPVV(X1),X2+1,99)
I $G(^DPT(DFN,.35)),(^(.35)<+($E(DT,1,3)_"0000")) S DGRPVV=$E(DGRPVV,0,7)_11_$E(DGRPVV,10,99)
K DIRUT,DUOUT,DTOUT
;
;Fields are numbered screen_item and put in that piece position.
;Because FM does not allow more than 100 pieces on a node, it was
;necessary to start a new node E10 for fields on screens 10 or higher.
;In these instances, the piece position will be screen_item-100 so,
;for example, screen 11, item 2 would be field 112, but piece 12.
;Items on screens <10 will be found on node E.
;
F I=100:0 S I=$O(^DD(391,I)) Q:I=""!(I>150) I $D(^(I,0)),($E(^(0),1)'="*"),'+$P(DGRPSCE1,"^",I-100) S X1=$E(I,1,2),X2=$E(I,3) I +X1 S DGRPVV(X1)=$E(DGRPVV(X1),0,X2-1)_1_$E(DGRPVV(X1),X2+1,99)
;
I $S('($D(DUZ)#2):0,'$D(^XUSEC("DG ELIGIBILITY",DUZ)):0,1:1) G ELVER ;if user holds eligibility key, skip
F I=.3,.32,.361 S DGRP(I)=$S($D(^DPT(DFN,I)):^(I),1:"")
S DGRPVV(10)=11 I $P(DGRP(.361),"^",1)="V" S DGRPVV(7)=111,DGRPVV(1)=1_$E(DGRPVV(1),2,99) ;if elig verified, can't edit elig data, name, ssn, or dob
I $P(DGRP(.3),"^",6)]"" S DGRPVV(8)=11 ;if monetary ben. verified, can't edit income screening data
I $P(DGRP(.32),"^",2)]"" S DGRPVV(6)=111111111 ;if service data verified, can't edit service screen
S DGRPVV(11)=$E(DGRPVV(11),1,4)_"0" ; turn on HBP to get to next screen where edit on/off will be controlled
;
ELVER ;set up variables for eligibility verification
;if elig ver option, only edit screens 1, 2, and 7 (and 6, 8, 9, 10,
; and 11 if they're turned on).
;
S DGRP(.361)=$G(^DPT(DFN,.361))
I $P(DGRP(.361),U,3)="H" S DGRPVV(10)=10
I $P($G(DGRP(.361)),U)="V",($P(DGRP(.361),U,3)="H") S DGRPVV(6)=$E(DGRPVV(6),1,5)_1_$E(DGRPVV(6),7,99),DGRPVV(11)=10000
S:'DGELVER DGRPLAST=$S($G(DGPRFLG)=1:5,1:15)
I DGELVER S DGRPVV="00111"_$E(DGRPVV,6,11)_"1111" F I=1:1:11 S J=$E(DGRPVV,I) I 'J S DGRPLAST=I
S:DGRPLAST=11 DGRPLAST=11.5 ; ASF; DG*5.3*997 - show screen 11.5 in DG Eligibility Verification options
Q K DGRPSC,DGRPSCE
Q
;
WW ;Write number on screens for display and/or edit (Z=number)
W:DGRPW !
S Z=$S(DGRPCM:Z,DGRPV:"<"_Z_">",$E(DGRPVV(DGRPS),Z):"<"_Z_">",1:"["_Z_"]")
I DGRPCM!($E(Z)="[") W @DGVI,Z,@DGVO
I 'DGRPCM&($E(Z)'="[") W Z
Q
;
WW1 ;spacing for screen display (Z=item to print)
F Z2=1:1:(Z1-$L(Z)) S Z=Z_" "
W Z K Z2
Q
;
WW2 ; Write number on screen for fields always selectable
W:DGRPW ! S Z="["_Z_"]"
I DGRPCM!($E(Z)="[") W @DGVI,Z,@DGVO
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGRPV 5730 printed Oct 16, 2024@18:57:43 Page 2
DGRPV ;ALB/MRL,RTK,PJR,BRM,TMK,AMA,LBD,TDM,PWC,JAM,JAM,ASF,LEG,ARF,JAM - REGISTRATION DEFINE VARIABLES ON ENTRY ;Apr 05, 2020@19:00
+1 ;;5.3;Registration;**109,114,247,190,327,365,343,397,415,489,546,545,451,624,677,672,689,716,688,797,842,871,887,941,985,997,1014,1064,1081,1093**;Aug 13, 1993;Build 12
+2 ;
+3 ;
+4 ;set up variables for registration screen processing
+5 ;
+6 ;DGRPVV :string of 15 ones and zeros each character corresponding to
+7 ; a particular screen (0 means allow edit, 1 means don't)
+8 ;
+9 ;DGRPVV(n):where n=screen number. String of x ones and zeros where
+10 ; x is the number of elements on screen n (0=edit, 1=don't)
+11 ;
+12 ;DGVI :Turn on high intensity
+13 ;DGVO :Turn off high intensity
+14 ;
EN DO DT^DICRW
IF '$DATA(DVBGUI)
DO HOME^%ZIS
+1 ;goto M if not high intensity
SET (DGVI,DGVO)=""""""
IF $SELECT('$DATA(IOST(0)):1,'$DATA(^DG(43,1,0)):1,'$PIECE(^DG(43,1,0),"^",36):1,$DATA(^DG(43,1,"TERM",IOST(0))):1,1:0)
GOTO M
+2 IF $DATA(^%ZIS(2,IOST(0),7))
SET I=^(7)
SET X=$SELECT($PIECE(I,"^",3)]"":3,1:2)
IF $LENGTH($PIECE(I,"^",1))
IF $LENGTH($PIECE(I,"^",X))
SET DGVI=$PIECE(I,"^",1)
SET DGVO=$PIECE(I,"^",X)
M IF $LENGTH(DGVI_DGVO)>4
SET X=132
XECUTE ^%ZOSF("RM")
+1 SET DGRPW=1
SET DGRPCM=0
SET DGRPU="UNANSWERED"
SET DGRPNA="NOT APPLICABLE"
SET DGRPV=$SELECT($DATA(DGRPV):DGRPV,1:1)
MSE ;Move MSE data from node .32 to .3216 multiple in Patient file #2
+1 ;DG*5.3*797
+2 IF '$DATA(^DPT(DFN,.3216))
DO MOVMSE^DGMSEUTL(DFN)
SC7 SET X=$SELECT('$DATA(^DPT(DFN,"TYPE")):0,1:+^("TYPE"))
if '$DATA(DGELVER)
SET DGELVER=0
+1 SET DGRPTYPE=$SELECT($DATA(^DG(391,+X,0)):^(0),1:"")
SET (DGRPSC,DGRPSCE,DGRPSCE1)=""
if '$DATA(DGELVER)
SET DGELVER=0
+2 IF DGRPTYPE'=""
SET DGRPSC=$GET(^DG(391,+X,"S"))
SET DGRPSCE=$GET(^("E"))
SET DGRPSCE1=$GET(^("E10"))
+3 ;
+4 ;Purple Heart Indicator
SET DGPH=$PIECE($GET(^DPT(DFN,.53)),U)
+5 IF $GET(DGPRFLG)=1
Begin DoDot:1
+6 SET DGRPVV="000001111111111"
End DoDot:1
+7 IF '$TEST
Begin DoDot:1
+8 SET DGRPVV="000000000000000"
End DoDot:1
+9 ; DG*5.3*985;JAM - Screen 1 now has 6 groups
+10 SET X="6^3^5^2^3^10^4^2^3^2^5^5^5^2^1"
+11 FOR I=1:1:15
SET J=+$PIECE(X,"^",I)
SET DGRPVV(I)=$SELECT((I<12)!(I=15):$EXTRACT("00000000000000000",1,J),1:$EXTRACT("11111111111111111",1,J))
+12 ;JAM - patch DG*5.3*941 - Screen 1.1 reformat - 4 groups
+13 SET DGRPVV(1.1)="0000"
+14 ;ARF - patch DG*5.3*1064 - Add group 6 to PATIENT DATA, SCREEN <2>
+15 ; DG*5.3*1093 - Screen 2, Group 6 is made read-only
+16 SET DGRPVV(2)="000101"
+17 ;ARF - patch DG*5.3*1081 - Make group 1 not editable on the INELIGIBLE/MISSING DATA, SCREEN <10>
+18 SET DGRPVV(10)="10"
+19 ; DG*5.3*997; ASF; Allowing selection for screen 11.5, group 1 (allows user to see sub-screen 11.5.1)
+20 ;LEG ;DG*5.3.1014 ; added extra "0" for group [2] ;was S DGRPVV(11.5)=0
SET DGRPVV(11.5)="00"
+21 ;POW status verified, no editing (DG*5.3*688)
IF $PIECE($GET(^DPT(DFN,.52)),U,9)'=""
SET $EXTRACT(DGRPVV(6),4)=1
+22 IF $GET(DGPH)]""
SET $EXTRACT(DGRPVV(6),8)=1
+23 SET $EXTRACT(DGRPVV(6),9,10)="11"
+24 ;
+25 FOR I=3,6,8,9,10,11
SET J=+$PIECE(DGRPSC,"^",I)
IF 'J
SET DGRPVV=$EXTRACT(DGRPVV,0,I-1)_1_$EXTRACT(DGRPVV,I+1,99)
+26 ;
+27 ;-- if patient type is TRICARE then turn off screens 2,4
+28 ;
+29 ;-- modified 08/20/2003 for NOIS Calls MAC-0400-61574 & AMA-0700-71769
+30 ;-- commented the line to allow screens 2 & 4 to display for Tricare
+31 ;I DGRPTYPE["TRICARE" F I=2,4 S J=+$P(DGRPSC,"^",I) I 'J S DGRPVV=$E(DGRPVV,0,I-1)_1_$E(DGRPVV,I+1,99)
+32 ;
+33 FOR I=31:0
SET I=$ORDER(^DD(391,I))
if I=""!(I>99)
QUIT
IF $DATA(^(I,0))
IF ($EXTRACT(^(0),1)'="*")
IF '+$PIECE(DGRPSCE,"^",I)
SET X1=$EXTRACT(I)
SET X2=$EXTRACT(I,2)
IF +X1
SET DGRPVV(X1)=$EXTRACT(DGRPVV(X1),0,X2-1)_1_$EXTRACT(DGRPVV(X1),X2+1,99)
+34 IF $GET(^DPT(DFN,.35))
IF (^(.35)<+($EXTRACT(DT,1,3)_"0000"))
SET DGRPVV=$EXTRACT(DGRPVV,0,7)_11_$EXTRACT(DGRPVV,10,99)
+35 KILL DIRUT,DUOUT,DTOUT
+36 ;
+37 ;Fields are numbered screen_item and put in that piece position.
+38 ;Because FM does not allow more than 100 pieces on a node, it was
+39 ;necessary to start a new node E10 for fields on screens 10 or higher.
+40 ;In these instances, the piece position will be screen_item-100 so,
+41 ;for example, screen 11, item 2 would be field 112, but piece 12.
+42 ;Items on screens <10 will be found on node E.
+43 ;
+44 FOR I=100:0
SET I=$ORDER(^DD(391,I))
if I=""!(I>150)
QUIT
IF $DATA(^(I,0))
IF ($EXTRACT(^(0),1)'="*")
IF '+$PIECE(DGRPSCE1,"^",I-100)
SET X1=$EXTRACT(I,1,2)
SET X2=$EXTRACT(I,3)
IF +X1
SET DGRPVV(X1)=$EXTRACT(DGRPVV(X1),0,X2-1)_1_$EXTRACT(DGRPVV(X1),X2+1,99)
+45 ;
+46 ;if user holds eligibility key, skip
IF $SELECT('($DATA(DUZ)#2):0,'$DATA(^XUSEC("DG ELIGIBILITY",DUZ)):0,1:1)
GOTO ELVER
+47 FOR I=.3,.32,.361
SET DGRP(I)=$SELECT($DATA(^DPT(DFN,I)):^(I),1:"")
+48 ;if elig verified, can't edit elig data, name, ssn, or dob
SET DGRPVV(10)=11
IF $PIECE(DGRP(.361),"^",1)="V"
SET DGRPVV(7)=111
SET DGRPVV(1)=1_$EXTRACT(DGRPVV(1),2,99)
+49 ;if monetary ben. verified, can't edit income screening data
IF $PIECE(DGRP(.3),"^",6)]""
SET DGRPVV(8)=11
+50 ;if service data verified, can't edit service screen
IF $PIECE(DGRP(.32),"^",2)]""
SET DGRPVV(6)=111111111
+51 ; turn on HBP to get to next screen where edit on/off will be controlled
SET DGRPVV(11)=$EXTRACT(DGRPVV(11),1,4)_"0"
+52 ;
ELVER ;set up variables for eligibility verification
+1 ;if elig ver option, only edit screens 1, 2, and 7 (and 6, 8, 9, 10,
+2 ; and 11 if they're turned on).
+3 ;
+4 SET DGRP(.361)=$GET(^DPT(DFN,.361))
+5 IF $PIECE(DGRP(.361),U,3)="H"
SET DGRPVV(10)=10
+6 IF $PIECE($GET(DGRP(.361)),U)="V"
IF ($PIECE(DGRP(.361),U,3)="H")
SET DGRPVV(6)=$EXTRACT(DGRPVV(6),1,5)_1_$EXTRACT(DGRPVV(6),7,99)
SET DGRPVV(11)=10000
+7 if 'DGELVER
SET DGRPLAST=$SELECT($GET(DGPRFLG)=1:5,1:15)
+8 IF DGELVER
SET DGRPVV="00111"_$EXTRACT(DGRPVV,6,11)_"1111"
FOR I=1:1:11
SET J=$EXTRACT(DGRPVV,I)
IF 'J
SET DGRPLAST=I
+9 ; ASF; DG*5.3*997 - show screen 11.5 in DG Eligibility Verification options
if DGRPLAST=11
SET DGRPLAST=11.5
Q KILL DGRPSC,DGRPSCE
+1 QUIT
+2 ;
WW ;Write number on screens for display and/or edit (Z=number)
+1 if DGRPW
WRITE !
+2 SET Z=$SELECT(DGRPCM:Z,DGRPV:"<"_Z_">",$EXTRACT(DGRPVV(DGRPS),Z):"<"_Z_">",1:"["_Z_"]")
+3 IF DGRPCM!($EXTRACT(Z)="[")
WRITE @DGVI,Z,@DGVO
+4 IF 'DGRPCM&($EXTRACT(Z)'="[")
WRITE Z
+5 QUIT
+6 ;
WW1 ;spacing for screen display (Z=item to print)
+1 FOR Z2=1:1:(Z1-$LENGTH(Z))
SET Z=Z_" "
+2 WRITE Z
KILL Z2
+3 QUIT
+4 ;
WW2 ; Write number on screen for fields always selectable
+1 if DGRPW
WRITE !
SET Z="["_Z_"]"
+2 IF DGRPCM!($EXTRACT(Z)="[")
WRITE @DGVI,Z,@DGVO
+3 QUIT
