source: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGINS.m@ 1270

Last change on this file since 1270 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 1.6 KB
RevLine 
[613]1DGINS ;ALB/MRL - INSURANCE COMPANY ADD/EDIT; 13 SEP 88@2200
2 ;;5.3;Registration;;Aug 13, 1993
31 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
4 ;
5ED 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:"")
6 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)
7 I DGINSW S:$P(DGINS(.13),"^",1)'=$P(DGINS1(.13),"^",1) C=1 S DGINSE(5)=$P(DGINS1(.13),"^",1)
8 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)
9 Q:'C W:DGINSW !!,"...Updating multiple ADDRESS field with new information...",!
10 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 "...."
11 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
12 ;
13DR 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 "...."
14 S DIC("DR")=DIC("DR")_"6///"_DGINS_";" K DGINSE Q
15 ;
16Q K DGNEW,X,X1,DIC,DIE,DR,I,C,DGINS,DGINS1,DGINSE,DGINSW,DA,Y Q
17 ;
18ALL F DGINS=0:0 S DGINS=$O(^DIC(36,DGINS)) Q:'DGINS S DIC="^DIC(36,",DGNEW=1,DGINSW=0 D ED W "."
19 W !!,"DONE!",*7 G Q
20OLD F I=.11,.13 S DGINS(I)=$S($D(^DIC(36,+DGINS,I)):^(I),1:"")
21 Q
Note: See TracBrowser for help on using the repository browser.