DGHELP ;ALB/JDS - EXECUTABLE ADT HELP PROMPTS ; 14 JUN 84 11:29
;;5.3;Registration;;Aug 13, 1993
;
EN ;called from ques node on dispo multiple
Q
P305 W !!,"Enter a string of characters, 1-5 characters in length",!,"It must only contain:",?25,"'A' for Aide and Assistance amount"
W !?25,"'H' for HB amount",!?25,"'S' for Social Security amount",!?25,"'R' for Retirement pay amount",!?25,"'D' for Disability amount."
W !?25,"'P' for Pension amount"
Q
UP I X'?.UNP F %=1:1:$L(X) I $E(X,%)?1L S X=$E(X,0,%-1)_$C($A(X,%)-32)_$E(X,%+1,999)
Q
IN S %=0 D UP I X]""&(Z[(U_X)) F I=$F(Z,U_X):1 S %=$E(Z,I) Q:%=U!(%']"") W %
E S %=-1
S:'% X=$E(X,1) K Z
Q
LOCK I '$D(^XUSEC("DG ELIGIBILITY",DUZ)),$D(^DPT(DFN,.361)) I $P(^(.361),U,1)="V" W !,"Verification of Eligibility done Eligibility Key required to edit this field" K X
Q
LOC I '$D(^XUSEC("DG ELIGIBILITY",DUZ)) W !,"Eligibility Key required to edit this field" K X
Q
DOB S Y=$P(^DPT(DA,0),U,3) I Y,X<(100000+Y) K X X ^DD("DD") W !,"Patient's DOB is ",Y
Q
SSN I X'?.UN F %=1:1:$L(X) I $E(X,%)?1P S X=$E(X,0,%-1)_$E(X,%+1,999)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGHELP 1106 printed Dec 13, 2024@02:43:41 Page 2
DGHELP ;ALB/JDS - EXECUTABLE ADT HELP PROMPTS ; 14 JUN 84 11:29
+1 ;;5.3;Registration;;Aug 13, 1993
+2 ;
EN ;called from ques node on dispo multiple
+1 QUIT
P305 WRITE !!,"Enter a string of characters, 1-5 characters in length",!,"It must only contain:",?25,"'A' for Aide and Assistance amount"
+1 WRITE !?25,"'H' for HB amount",!?25,"'S' for Social Security amount",!?25,"'R' for Retirement pay amount",!?25,"'D' for Disability amount."
+2 WRITE !?25,"'P' for Pension amount"
+3 QUIT
UP IF X'?.UNP
FOR %=1:1:$LENGTH(X)
IF $EXTRACT(X,%)?1L
SET X=$EXTRACT(X,0,%-1)_$CHAR($ASCII(X,%)-32)_$EXTRACT(X,%+1,999)
+1 QUIT
IN SET %=0
DO UP
IF X]""&(Z[(U_X))
FOR I=$FIND(Z,U_X):1
SET %=$EXTRACT(Z,I)
if %=U!(%']"")
QUIT
WRITE %
+1 IF '$TEST
SET %=-1
+2 if '%
SET X=$EXTRACT(X,1)
KILL Z
+3 QUIT
LOCK IF '$DATA(^XUSEC("DG ELIGIBILITY",DUZ))
IF $DATA(^DPT(DFN,.361))
IF $PIECE(^(.361),U,1)="V"
WRITE !,"Verification of Eligibility done Eligibility Key required to edit this field"
KILL X
+1 QUIT
LOC IF '$DATA(^XUSEC("DG ELIGIBILITY",DUZ))
WRITE !,"Eligibility Key required to edit this field"
KILL X
+1 QUIT
DOB SET Y=$PIECE(^DPT(DA,0),U,3)
IF Y
IF X<(100000+Y)
KILL X
XECUTE ^DD("DD")
WRITE !,"Patient's DOB is ",Y
+1 QUIT
SSN IF X'?.UN
FOR %=1:1:$LENGTH(X)
IF $EXTRACT(X,%)?1P
SET X=$EXTRACT(X,0,%-1)_$EXTRACT(X,%+1,999)
