- DGINS ;ALB/MRL - INSURANCE COMPANY ADD/EDIT; 13 SEP 88@2200
- ;;5.3;Registration;**1015**;Aug 13, 1993;Build 21
- 1 W !! D Q S DGINS="",DGINSW=1,DIC="^DIC(36,",DIC(0)="AEQMLZ" D ^DIC G Q:Y'>0 S DGINS=+Y,DGNEW=+$P(Y,"^",3) D ED G 1
- ;
- ED D OLD S DIE=DIC,DR=".01;1;2;.05:.08;.09;.1;.111;S:X="""" Y=.114;.112;S:X="""" Y=.114;.113:.116;.131;.132;.133;",(DA,Y)=DGINS D ^DIE:DGINSW F I=.11,.13 S DGINS1(I)=$S($D(^DIC(36,DGINS,I)):^(I),1:"")
- I DGINSW S C=0 F I=1,4,5,6 S:$P(DGINS(.11),"^",I)'=$P(DGINS1(.11),"^",I) C=1 S X1=$S(I=1:.01,1:(I-2)),DGINSE(X1)=$P(DGINS1(.11),"^",I)
- I DGINSW S:$P(DGINS(.13),"^",1)'=$P(DGINS1(.13),"^",1) C=1 S DGINSE(5)=$P(DGINS1(.13),"^",1)
- I DGNEW S C=1,DGINSE(5)=$P(DGINS1(.13),"^",1) F I=1,4,5,6 S X1=$S(I=1:.01,1:(I-2)) I $P(DGINS1(.11),"^",I)]"" S DGINSE(X1)=$P(DGINS1(.11),"^",I)
- Q:'C W:DGINSW !!,"...Updating multiple ADDRESS field with new information...",!
- I $D(^DIC(36,+DGINS,2,1,0)) S:'$D(^DIC(36,+DGINS,2,0)) ^(0)="^36.02I^1^1" S DIK="^DIC(36,"_DGINS_",2,",DA(2)=36,DA(1)=DGINS,DA=1 D ^DIK K DIK W:DGINSW "...."
- S DIC(0)="QMZL",DIC="^DIC(36,"_DGINS_",2,",DA(2)=36,DA(1)=DGINS,(DA,DINUM)=1,X=$P(DGINS1(.11),"^",1) I X]"" S:'$D(^DIC(36,+DGINS,2,0)) ^(0)="^36.02I^^" K DD,DO D DR,FILE^DICN K DINUM W:DGINSW !!,"DONE...",*7 Q
- ;
- DR K DR S DIC("DR")="" F I=0:0 S I=$O(DGINSE(I)) Q:'I S DIC("DR")=DIC("DR")_I_"///"_DGINSE(I)_";" W:DGINSW "...."
- S DIC("DR")=DIC("DR")_"6///"_DGINS_";" K DGINSE Q
- ;
- Q K DGNEW,X,X1,DIC,DIE,DR,I,C,DGINS,DGINS1,DGINSE,DGINSW,DA,Y Q
- ;
- ALL F DGINS=0:0 S DGINS=$O(^DIC(36,DGINS)) Q:'DGINS S DIC="^DIC(36,",DGNEW=1,DGINSW=0 D ED W "."
- W !!,"DONE!",*7 G Q
- OLD F I=.11,.13 S DGINS(I)=$S($D(^DIC(36,+DGINS,I)):^(I),1:"")
- Q
- DGINS ;ALB/MRL - INSURANCE COMPANY ADD/EDIT; 13 SEP 88@2200
- +1 ;;5.3;Registration;**1015**;Aug 13, 1993;Build 21
- 1 WRITE !!
- DO Q
- SET DGINS=""
- SET DGINSW=1
- SET DIC="^DIC(36,"
- SET DIC(0)="AEQMLZ"
- DO ^DIC
- IF Y'>0
- GOTO Q
- SET DGINS=+Y
- SET DGNEW=+$PIECE(Y,"^",3)
- DO ED
- GOTO 1
- +1 ;
- ED DO OLD
- SET DIE=DIC
- SET DR=".01;1;2;.05:.08;.09;.1;.111;S:X="""" Y=.114;.112;S:X="""" Y=.114;.113:.116;.131;.132;.133;"
- SET (DA,Y)=DGINS
- IF DGINSW
- DO ^DIE
- FOR I=.11,.13
- SET DGINS1(I)=$SELECT($DATA(^DIC(36,DGINS,I)):^(I),1:"")
- +1 IF DGINSW
- SET C=0
- FOR I=1,4,5,6
- IF $PIECE(DGINS(.11),"^",I)'=$PIECE(DGINS1(.11),"^",I)
- SET C=1
- SET X1=$SELECT(I=1:.01,1:(I-2))
- SET DGINSE(X1)=$PIECE(DGINS1(.11),"^",I)
- +2 IF DGINSW
- IF $PIECE(DGINS(.13),"^",1)'=$PIECE(DGINS1(.13),"^",1)
- SET C=1
- SET DGINSE(5)=$PIECE(DGINS1(.13),"^",1)
- +3 IF DGNEW
- SET C=1
- SET DGINSE(5)=$PIECE(DGINS1(.13),"^",1)
- FOR I=1,4,5,6
- SET X1=$SELECT(I=1:.01,1:(I-2))
- IF $PIECE(DGINS1(.11),"^",I)]""
- SET DGINSE(X1)=$PIECE(DGINS1(.11),"^",I)
- +4 IF 'C
- QUIT
- IF DGINSW
- WRITE !!,"...Updating multiple ADDRESS field with new information...",!
- +5 IF $DATA(^DIC(36,+DGINS,2,1,0))
- IF '$DATA(^DIC(36,+DGINS,2,0))
- SET ^(0)="^36.02I^1^1"
- SET DIK="^DIC(36,"_DGINS_",2,"
- SET DA(2)=36
- SET DA(1)=DGINS
- SET DA=1
- DO ^DIK
- KILL DIK
- IF DGINSW
- WRITE "...."
- +6 SET DIC(0)="QMZL"
- SET DIC="^DIC(36,"_DGINS_",2,"
- SET DA(2)=36
- SET DA(1)=DGINS
- SET (DA,DINUM)=1
- SET X=$PIECE(DGINS1(.11),"^",1)
- IF X]""
- IF '$DATA(^DIC(36,+DGINS,2,0))
- SET ^(0)="^36.02I^^"
- KILL DD,DO
- DO DR
- DO FILE^DICN
- KILL DINUM
- IF DGINSW
- WRITE !!,"DONE...",*7
- QUIT
- +7 ;
- DR KILL DR
- SET DIC("DR")=""
- FOR I=0:0
- SET I=$ORDER(DGINSE(I))
- IF 'I
- QUIT
- SET DIC("DR")=DIC("DR")_I_"///"_DGINSE(I)_";"
- IF DGINSW
- WRITE "...."
- +1 SET DIC("DR")=DIC("DR")_"6///"_DGINS_";"
- KILL DGINSE
- QUIT
- +2 ;
- Q KILL DGNEW,X,X1,DIC,DIE,DR,I,C,DGINS,DGINS1,DGINSE,DGINSW,DA,Y
- QUIT
- +1 ;
- ALL FOR DGINS=0:0
- SET DGINS=$ORDER(^DIC(36,DGINS))
- IF 'DGINS
- QUIT
- SET DIC="^DIC(36,"
- SET DGNEW=1
- SET DGINSW=0
- DO ED
- WRITE "."
- +1 WRITE !!,"DONE!",*7
- GOTO Q
- OLD FOR I=.11,.13
- SET DGINS(I)=$SELECT($DATA(^DIC(36,+DGINS,I)):^(I),1:"")
- +1 QUIT
