DVBHDBA1 ;pke/isc-albany - Check, add to file 31; 25 AUG 88@12:00
;;V4.0;HINQ;;03/25/92
EN K DO,DD S U="^" D DT^DICRW
;
W !!?5,"*** Updating 'Disability Condition' file #31 ***",!!
;
ENT S DIF="^TMP($J,",XCNP=0 K ^TMP($J)
F ROU="DVBHDBA2","DVBHDBA3","DVBHDBA4","DVBHDBA5","DVBHDBA6","DVBHDBA7","DVBHDBA8","DVBHDBA9","DVBHDBAA","DVBHDBAB" S X=ROU X ^%ZOSF("LOAD") W ".."
K DIF,XCNP,ROU
;
S XMSUB="Disability Condition file #31 Changes",XMDUN="HINQ update"
I $D(DUZ)#2,DUZ S XMDUZ=DUZ
E S XMDUZ=.5
S XMY(XMDUZ)=""
D GET^XMA2
;
ADD S (LCNT,ACNT,CCNT)=0,$P(BL," ",40)="" W !!
S (DIE,DIC)="^DIC(31,",DIC(0)="L"
F DVBZ=0:0 S DVBZ=$O(^TMP($J,DVBZ)) Q:'DVBZ I $D(^(DVBZ,0)) S DCODE=$P(^(0),";;",2) I +DCODE S DTEXT=$P(DCODE,"^",2),DCODE=+DCODE D CHKADD
;
W !!?5,"*** "
I 'ACNT W "No entry"
E W ACNT," ",$S(ACNT>1:"entries",1:"entry")
W " added to file #31 ***",!
W !!?5,"*** "
;
I 'CCNT W "No entry"
E W CCNT," ",$S(CCNT>1:"entries",1:"entry")
W " changed in file #31 ***",!
;
S ^XMB(3.9,XMZ,2,0)="^^"_LCNT_"^"_LCNT_"^"_DT_"^"
D ENT1^XMD
;
KIL K XMDUZ,XMSUB,XMDUN,XMZ,LINE,%I,%N,BL
K INT,LCNT,ACNT,CCNT,DCODE,DTEXT,Z,DIE,DIC,DR,DA,DD,D0,DQ,X,Y,DVBZ
K ^TMP($J) Q
;
CHKADD I '$D(^DIC(31,"C",DCODE)) S DIC("DR")="2///"_DCODE,X=DTEXT K DD,DO D FILE^DICN K DO,DD S ACNT=ACNT+1 D M1 Q
;
S INT=0,INT=$O(^DIC(31,"C",DCODE,INT)) I INT,$P(^DIC(31,INT,0),"^")'=DTEXT S DR=".01///"_DTEXT,DA=INT D M2,^DIE S CCNT=CCNT+1 Q
;
Q
M1 S LINE="'"_DCODE_"' "_DTEXT_" ...added to file..." D MSET Q
;
M2 S LINE=$E(DCODE_" "_$P(^DIC(31,INT,0),"^")_BL,1,37)_"==> "_DTEXT
;
MSET S LCNT=LCNT+1,^XMB(3.9,XMZ,2,LCNT,0)=LINE
I DCODE#50=0 W "."
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDVBHDBA1 1703 printed Feb 18, 2025@23:24:40 Page 2
DVBHDBA1 ;pke/isc-albany - Check, add to file 31; 25 AUG 88@12:00
+1 ;;V4.0;HINQ;;03/25/92
EN KILL DO,DD
SET U="^"
DO DT^DICRW
+1 ;
+2 WRITE !!?5,"*** Updating 'Disability Condition' file #31 ***",!!
+3 ;
ENT SET DIF="^TMP($J,"
SET XCNP=0
KILL ^TMP($JOB)
+1 FOR ROU="DVBHDBA2","DVBHDBA3","DVBHDBA4","DVBHDBA5","DVBHDBA6","DVBHDBA7","DVBHDBA8","DVBHDBA9","DVBHDBAA","DVBHDBAB"
SET X=ROU
XECUTE ^%ZOSF("LOAD")
WRITE ".."
+2 KILL DIF,XCNP,ROU
+3 ;
+4 SET XMSUB="Disability Condition file #31 Changes"
SET XMDUN="HINQ update"
+5 IF $DATA(DUZ)#2
IF DUZ
SET XMDUZ=DUZ
+6 IF '$TEST
SET XMDUZ=.5
+7 SET XMY(XMDUZ)=""
+8 DO GET^XMA2
+9 ;
ADD SET (LCNT,ACNT,CCNT)=0
SET $PIECE(BL," ",40)=""
WRITE !!
+1 SET (DIE,DIC)="^DIC(31,"
SET DIC(0)="L"
+2 FOR DVBZ=0:0
SET DVBZ=$ORDER(^TMP($JOB,DVBZ))
if 'DVBZ
QUIT
IF $DATA(^(DVBZ,0))
SET DCODE=$PIECE(^(0),";;",2)
IF +DCODE
SET DTEXT=$PIECE(DCODE,"^",2)
SET DCODE=+DCODE
DO CHKADD
+3 ;
+4 WRITE !!?5,"*** "
+5 IF 'ACNT
WRITE "No entry"
+6 IF '$TEST
WRITE ACNT," ",$SELECT(ACNT>1:"entries",1:"entry")
+7 WRITE " added to file #31 ***",!
+8 WRITE !!?5,"*** "
+9 ;
+10 IF 'CCNT
WRITE "No entry"
+11 IF '$TEST
WRITE CCNT," ",$SELECT(CCNT>1:"entries",1:"entry")
+12 WRITE " changed in file #31 ***",!
+13 ;
+14 SET ^XMB(3.9,XMZ,2,0)="^^"_LCNT_"^"_LCNT_"^"_DT_"^"
+15 DO ENT1^XMD
+16 ;
KIL KILL XMDUZ,XMSUB,XMDUN,XMZ,LINE,%I,%N,BL
+1 KILL INT,LCNT,ACNT,CCNT,DCODE,DTEXT,Z,DIE,DIC,DR,DA,DD,D0,DQ,X,Y,DVBZ
+2 KILL ^TMP($JOB)
QUIT
+3 ;
CHKADD IF '$DATA(^DIC(31,"C",DCODE))
SET DIC("DR")="2///"_DCODE
SET X=DTEXT
KILL DD,DO
DO FILE^DICN
KILL DO,DD
SET ACNT=ACNT+1
DO M1
QUIT
+1 ;
+2 SET INT=0
SET INT=$ORDER(^DIC(31,"C",DCODE,INT))
IF INT
IF $PIECE(^DIC(31,INT,0),"^")'=DTEXT
SET DR=".01///"_DTEXT
SET DA=INT
DO M2
DO ^DIE
SET CCNT=CCNT+1
QUIT
+3 ;
+4 QUIT
M1 SET LINE="'"_DCODE_"' "_DTEXT_" ...added to file..."
DO MSET
QUIT
+1 ;
M2 SET LINE=$EXTRACT(DCODE_" "_$PIECE(^DIC(31,INT,0),"^")_BL,1,37)_"==> "_DTEXT
+1 ;
MSET SET LCNT=LCNT+1
SET ^XMB(3.9,XMZ,2,LCNT,0)=LINE
+1 IF DCODE#50=0
WRITE "."
+2 QUIT
