AVA4A7.m

AVA4A7 ; IHS/ORDC/LJF - GIVE PROVIDER KEY,CALLED BY XREF ; 27-MAY-1993

 ;;93.2;VA SUPPORT FILES;;JUL 01, 1993;Build 12

 ;

 ;

 Q

F6S ;EP;Give provider the key.

 ;called by mumps xref on PROVIDER CLASS in file 200

 N AVAX,AVAY,X

 S X=$G(^VA(200,DA,"I")) I X,X<DT Q  ;see if inactive

 S AVAY=DA

 S AVAX=$O(^DIC(19.1,"B","PROVIDER",0)) I 'AVAX Q  ;get index

 I $D(^VA(200,AVAY,51,AVAX,0)) Q  ;already have it.

 N DD,DO,DIC,DS,DA

 S DIC="^VA(200,DA(1),51,",DIC(0)="NML",(X,DINUM)=AVAX

 S DA(1)=AVAY,DIC("P")=$P($G(^DD(200,51,0)),U,2) D FILE^DICN ;give it

 ;

 S AVAX=$P(^DIC(3,AVAY,0),U,16) Q:'AVAX

 ;stuff new person fields into provider file entry

 I $D(^DIC(6,AVAX,0))#2 S DIK="^VA(200,",DA=AVAY D IX1^DIK

 Q

 ;

 ;

F6K ;EP;Remove provider key if provider class has been deleted

 ;called by mumps xref on PROVIDER CLASS in file 200

 N AVAX,AVAY,X

 S X=$G(^VA(200,DA,"I")) I X,X<DT Q  ;see if inactive

 S AVAY=DA Q:$P($G(^VA(200,AVAY,"PS")),U,5)]""

 S AVAX=$O(^DIC(19.1,"B","PROVIDER",0)) I 'AVAX Q  ;get index

 I '$D(^VA(200,AVAY,51,AVAX)) Q  ;doesn't have key

 N DD,DO,DIK,DS,DA,DIC

 S DA(1)=AVAY,DIK="^VA(200,"_DA(1)_",51,",DA=AVAX D ^DIK

 Q

AVA4A7    ; IHS/ORDC/LJF - GIVE PROVIDER KEY,CALLED BY XREF ; 27-MAY-1993

 +1       ;;93.2;VA SUPPORT FILES;;JUL 01, 1993;Build 12

 +2       ;

 +3       ;

 +4        QUIT 

F6S       ;EP;Give provider the key.

 +1       ;called by mumps xref on PROVIDER CLASS in file 200

 +2        NEW AVAX,AVAY,X

 +3       ;see if inactive

           SET X=$GET(^VA(200,DA,"I"))

           IF X

               IF X<DT

                   QUIT 

 +4        SET AVAY=DA

 +5       ;get index

           SET AVAX=$ORDER(^DIC(19.1,"B","PROVIDER",0))

           IF 'AVAX

               QUIT 

 +6       ;already have it.

           IF $DATA(^VA(200,AVAY,51,AVAX,0))

               QUIT 

 +7        NEW DD,DO,DIC,DS,DA

 +8        SET DIC="^VA(200,DA(1),51,"

           SET DIC(0)="NML"

           SET (X,DINUM)=AVAX

 +9       ;give it

           SET DA(1)=AVAY

           SET DIC("P")=$PIECE($GET(^DD(200,51,0)),U,2)

           DO FILE^DICN

 +10      ;

 +11       SET AVAX=$PIECE(^DIC(3,AVAY,0),U,16)

           IF 'AVAX

               QUIT 

 +12      ;stuff new person fields into provider file entry

 +13       IF $DATA(^DIC(6,AVAX,0))#2

               SET DIK="^VA(200,"

               SET DA=AVAY

               DO IX1^DIK

 +14       QUIT 

 +15      ;

 +16      ;

F6K       ;EP;Remove provider key if provider class has been deleted

 +1       ;called by mumps xref on PROVIDER CLASS in file 200

 +2        NEW AVAX,AVAY,X

 +3       ;see if inactive

           SET X=$GET(^VA(200,DA,"I"))

           IF X

               IF X<DT

                   QUIT 

 +4        SET AVAY=DA

           IF $PIECE($GET(^VA(200,AVAY,"PS")),U,5)]""

               QUIT 

 +5       ;get index

           SET AVAX=$ORDER(^DIC(19.1,"B","PROVIDER",0))

           IF 'AVAX

               QUIT 

 +6       ;doesn't have key

           IF '$DATA(^VA(200,AVAY,51,AVAX))

               QUIT 

 +7        NEW DD,DO,DIK,DS,DA,DIC

 +8        SET DA(1)=AVAY

           SET DIK="^VA(200,"_DA(1)_",51,"

           SET DA=AVAX

           DO ^DIK

 +9        QUIT