FBXIP33.m

FBXIP33 ;WCIOFO/MJE-IMPORT GPCI/ZIP CODE DATA ;9/18/2001

 ;;3.5;FEE BASIS;**33**;JAN 30, 1995

 Q

 ;

PS ; post-install entry point

 ; create KIDS checkpoints with call backs

 N FBX,Y

 F FBX="LOAD" D

 .S Y=$$NEWCP^XPDUTL(FBX,FBX_"^FBXIP33")

 .I 'Y D BMES^XPDUTL("ERROR Creating "_FBX_" Checkpoint.")

 N FBX,Y

 F FBX="LOADA" D

 .S Y=$$NEWCP^XPDUTL(FBX,FBX_"^FBXIP33A")

 .I 'Y D BMES^XPDUTL("ERROR Creating "_FBX_" Checkpoint.")

 N FBX,Y

 F FBX="MRGDOL" D

 .S Y=$$NEWCP^XPDUTL(FBX,FBX_"^FBXIP33B")

 .I 'Y D BMES^XPDUTL("ERROR Creating "_FBX_" Checkpoint.")

 Q

 ;

 ;

LOAD ; Load data into 162.96 using included DATA as source

 N FBI,FBY,X,ZIP

 D BMES^XPDUTL("--Updating file 162.96")

 F FBI=1:1 S FBY=$P($T(DATA+FBI),";;",2) Q:FBY="END"  D

 . S ZIP=$P(FBY,U)

 . S Y=$O(^FB(162.96,"B",ZIP,0))

 . I 'Y D  Q:Y'>0

 . . K DA,DIC

 . . S DIC="^FB(162.96,",DLAYGO=162.96,DIC(0)="L",X=ZIP

 . . K DD,DO D FILE^DICN I Y'>0 D BMES^XPDUTL("ERROR ADDING NEW ZIP "_ZIP)

 . . K DIC,DLAYGO

 . ;

 . K DA,DIC

 . S DA(1)=+Y

 . S Y=$O(^FB(162.96,DA(1),"CY","B",2001,0))

 . I 'Y D  Q:Y'>0

 . . S DIC="^FB(162.96,"_DA(1)_",""CY"",",DIC(0)="L",DIC("P")="162.961A"

 . . S X=2001

 . . K DD,DO D FILE^DICN I Y'>0 D BMES^XPDUTL("ERROR ADDING 2001 for "_ZIP)

 . . K DIC,DLAYGO

 . S DA=+Y

 . ;

 . S DIE="^FB(162.96,"_DA(1)_",""CY"","

 . S DR=".02///"_$P(FBY,U,2)_";.03///"_$P(FBY,U,3)_";.04///"_$P(FBY,U,4)

 . D ^DIE K DIE,DR,DA

 ;

 D BMES^XPDUTL("---Update of file 162.96 complete")

 Q

 ;

DATA ;This is the ZIP and GPCI data ZIP^GPCI1^GCPI2^GPCI3

 ;;12062^1.01^1.079^1.3

 ;;15295^0.989^0.93^0.705

 ;;18202^0.989^0.93^0.705

 ;;19415^1.023^1.09^1.31

 ;;19505^1.023^1.09^1.31

 ;;22107^1.05^1.164^0.97

 ;;22108^1.05^1.164^0.97

 ;;23114^0.985^0.939^0.529

 ;;27205^0.97^0.927^0.546

 ;;27332^0.97^0.927^0.546

 ;;27517^0.97^0.927^0.546

 ;;27537^0.97^0.927^0.546

 ;;28271^0.97^0.927^0.546

 ;;30156^1.006^1.046^0.943

 ;;30160^1.006^1.046^0.943

 ;;31059^0.97^0.896^0.943

 ;;32128^0.975^0.947^1.296

 ;;32162^0.975^0.947^1.296

 ;;33508^0.975^0.947^1.296

 ;;33558^0.975^0.947^1.296

 ;;33559^0.975^0.947^1.296

 ;;33896^0.975^0.947^1.296

 ;;33897^0.975^0.947^1.296

 ;;33898^0.975^0.947^1.296

 ;;34211^0.975^0.947^1.296

 ;;34212^0.975^0.947^1.296

 ;;34269^0.975^0.947^1.296

 ;;34288^0.975^0.947^1.296

 ;;34289^0.975^0.947^1.296

 ;;38016^0.975^0.9^0.572

 ;;38571^0.975^0.9^0.572

 ;;38572^0.975^0.9^0.572

 ;;39540^0.957^0.841^0.75

 ;;45280^0.989^0.941^1.016

 ;;48085^1.042^1.03^2.903

 ;;48088^1.042^1.03^2.903

 ;;60103^1.006^1.069^1.505

 ;;60133^1.027^1.09^1.745

 ;;60527^1.006^1.069^1.505

 ;;60696^1.027^1.09^1.745

 ;;61616^0.964^0.888^1.074

 ;;63041^0.946^0.826^0.979

 ;;63190^0.994^0.94^1.022

 ;;75071^0.966^0.884^0.914

 ;;75098^0.966^0.884^0.914

 ;;75109^0.966^0.884^0.914

 ;;75252^0.966^0.884^0.914

 ;;75254^1.01^1.04^0.93

 ;;75287^0.966^0.884^0.914

 ;;75645^0.966^0.884^0.914

 ;;75752^0.966^0.884^0.914

 ;;75803^0.966^0.884^0.914

 ;;75965^0.966^0.884^0.914

 ;;77053^0.966^0.884^0.914

 ;;77615^0.966^0.884^0.914

 ;;78641^0.986^0.998^0.854

 ;;78737^0.966^0.884^0.914

 ;;80285^0.986^0.981^0.817

 ;;84194^0.977^0.925^0.619

 ;;84195^0.977^0.925^0.619

 ;;85042^0.994^0.975^1.15

 ;;85218^0.994^0.975^1.15

 ;;85297^0.994^0.975^1.15

 ;;85383^0.994^0.975^1.15

 ;;87507^0.973^0.905^0.809

 ;;87508^0.973^0.905^0.809

 ;;89074^1.005^1.035^1.103

 ;;89084^1.005^1.035^1.103

 ;;89086^1.005^1.035^1.103

 ;;91387^1.055^1.169^0.901

 ;;91390^1.055^1.169^0.901

 ;;92637^1.036^1.187^0.901

 ;;92809^1.036^1.187^0.901

 ;;94303^1.062^1.321^0.653

 ;;95033^1.007^1.039^0.723

 ;;98082^0.982^0.974^0.765

 ;;00727^0.882^0.72^0.317

 ;;03258^0.987^1.032^0.919

 ;;07086^1.057^1.192^0.827

 ;;08205^1.028^1.102^0.827

 ;;END

 ;

 ;FBXIP33

--- Routine Detail   --- with STRUCTURED ROUTINE LISTING ---FBXIP33   3788     printed  Mar 13, 2025@21:06:34                                                                                                                                                                                                     Page 2

FBXIP33   ;WCIOFO/MJE-IMPORT GPCI/ZIP CODE DATA ;9/18/2001

 +1       ;;3.5;FEE BASIS;**33**;JAN 30, 1995

 +2        QUIT 

 +3       ;

PS        ; post-install entry point

 +1       ; create KIDS checkpoints with call backs

 +2        NEW FBX,Y

 +3        FOR FBX="LOAD"

               Begin DoDot:1

 +4                SET Y=$$NEWCP^XPDUTL(FBX,FBX_"^FBXIP33")

 +5                IF 'Y

                       DO BMES^XPDUTL("ERROR Creating "_FBX_" Checkpoint.")

               End DoDot:1

 +6        NEW FBX,Y

 +7        FOR FBX="LOADA"

               Begin DoDot:1

 +8                SET Y=$$NEWCP^XPDUTL(FBX,FBX_"^FBXIP33A")

 +9                IF 'Y

                       DO BMES^XPDUTL("ERROR Creating "_FBX_" Checkpoint.")

               End DoDot:1

 +10       NEW FBX,Y

 +11       FOR FBX="MRGDOL"

               Begin DoDot:1

 +12               SET Y=$$NEWCP^XPDUTL(FBX,FBX_"^FBXIP33B")

 +13               IF 'Y

                       DO BMES^XPDUTL("ERROR Creating "_FBX_" Checkpoint.")

               End DoDot:1

 +14       QUIT 

 +15      ;

 +16      ;

LOAD      ; Load data into 162.96 using included DATA as source

 +1        NEW FBI,FBY,X,ZIP

 +2        DO BMES^XPDUTL("--Updating file 162.96")

 +3        FOR FBI=1:1

               SET FBY=$PIECE($TEXT(DATA+FBI),";;",2)

               if FBY="END"

                   QUIT 

               Begin DoDot:1

 +4                SET ZIP=$PIECE(FBY,U)

 +5                SET Y=$ORDER(^FB(162.96,"B",ZIP,0))

 +6                IF 'Y

                       Begin DoDot:2

 +7                        KILL DA,DIC

 +8                        SET DIC="^FB(162.96,"

                           SET DLAYGO=162.96

                           SET DIC(0)="L"

                           SET X=ZIP

 +9                        KILL DD,DO

                           DO FILE^DICN

                           IF Y'>0

                               DO BMES^XPDUTL("ERROR ADDING NEW ZIP "_ZIP)

 +10                       KILL DIC,DLAYGO

                       End DoDot:2

                       if Y'>0

                           QUIT 

 +11      ;

 +12               KILL DA,DIC

 +13               SET DA(1)=+Y

 +14               SET Y=$ORDER(^FB(162.96,DA(1),"CY","B",2001,0))

 +15               IF 'Y

                       Begin DoDot:2

 +16                       SET DIC="^FB(162.96,"_DA(1)_",""CY"","

                           SET DIC(0)="L"

                           SET DIC("P")="162.961A"

 +17                       SET X=2001

 +18                       KILL DD,DO

                           DO FILE^DICN

                           IF Y'>0

                               DO BMES^XPDUTL("ERROR ADDING 2001 for "_ZIP)

 +19                       KILL DIC,DLAYGO

                       End DoDot:2

                       if Y'>0

                           QUIT 

 +20               SET DA=+Y

 +21      ;

 +22               SET DIE="^FB(162.96,"_DA(1)_",""CY"","

 +23               SET DR=".02///"_$PIECE(FBY,U,2)_";.03///"_$PIECE(FBY,U,3)_";.04///"_$PIECE(FBY,U,4)

 +24               DO ^DIE

                   KILL DIE,DR,DA

               End DoDot:1

 +25      ;

 +26       DO BMES^XPDUTL("---Update of file 162.96 complete")

 +27       QUIT 

 +28      ;

DATA      ;This is the ZIP and GPCI data ZIP^GPCI1^GCPI2^GPCI3

 +1       ;;12062^1.01^1.079^1.3

 +2       ;;15295^0.989^0.93^0.705

 +3       ;;18202^0.989^0.93^0.705

 +4       ;;19415^1.023^1.09^1.31

 +5       ;;19505^1.023^1.09^1.31

 +6       ;;22107^1.05^1.164^0.97

 +7       ;;22108^1.05^1.164^0.97

 +8       ;;23114^0.985^0.939^0.529

 +9       ;;27205^0.97^0.927^0.546

 +10      ;;27332^0.97^0.927^0.546

 +11      ;;27517^0.97^0.927^0.546

 +12      ;;27537^0.97^0.927^0.546

 +13      ;;28271^0.97^0.927^0.546

 +14      ;;30156^1.006^1.046^0.943

 +15      ;;30160^1.006^1.046^0.943

 +16      ;;31059^0.97^0.896^0.943

 +17      ;;32128^0.975^0.947^1.296

 +18      ;;32162^0.975^0.947^1.296

 +19      ;;33508^0.975^0.947^1.296

 +20      ;;33558^0.975^0.947^1.296

 +21      ;;33559^0.975^0.947^1.296

 +22      ;;33896^0.975^0.947^1.296

 +23      ;;33897^0.975^0.947^1.296

 +24      ;;33898^0.975^0.947^1.296

 +25      ;;34211^0.975^0.947^1.296

 +26      ;;34212^0.975^0.947^1.296

 +27      ;;34269^0.975^0.947^1.296

 +28      ;;34288^0.975^0.947^1.296

 +29      ;;34289^0.975^0.947^1.296

 +30      ;;38016^0.975^0.9^0.572

 +31      ;;38571^0.975^0.9^0.572

 +32      ;;38572^0.975^0.9^0.572

 +33      ;;39540^0.957^0.841^0.75

 +34      ;;45280^0.989^0.941^1.016

 +35      ;;48085^1.042^1.03^2.903

 +36      ;;48088^1.042^1.03^2.903

 +37      ;;60103^1.006^1.069^1.505

 +38      ;;60133^1.027^1.09^1.745

 +39      ;;60527^1.006^1.069^1.505

 +40      ;;60696^1.027^1.09^1.745

 +41      ;;61616^0.964^0.888^1.074

 +42      ;;63041^0.946^0.826^0.979

 +43      ;;63190^0.994^0.94^1.022

 +44      ;;75071^0.966^0.884^0.914

 +45      ;;75098^0.966^0.884^0.914

 +46      ;;75109^0.966^0.884^0.914

 +47      ;;75252^0.966^0.884^0.914

 +48      ;;75254^1.01^1.04^0.93

 +49      ;;75287^0.966^0.884^0.914

 +50      ;;75645^0.966^0.884^0.914

 +51      ;;75752^0.966^0.884^0.914

 +52      ;;75803^0.966^0.884^0.914

 +53      ;;75965^0.966^0.884^0.914

 +54      ;;77053^0.966^0.884^0.914

 +55      ;;77615^0.966^0.884^0.914

 +56      ;;78641^0.986^0.998^0.854

 +57      ;;78737^0.966^0.884^0.914

 +58      ;;80285^0.986^0.981^0.817

 +59      ;;84194^0.977^0.925^0.619

 +60      ;;84195^0.977^0.925^0.619

 +61      ;;85042^0.994^0.975^1.15

 +62      ;;85218^0.994^0.975^1.15

 +63      ;;85297^0.994^0.975^1.15

 +64      ;;85383^0.994^0.975^1.15

 +65      ;;87507^0.973^0.905^0.809

 +66      ;;87508^0.973^0.905^0.809

 +67      ;;89074^1.005^1.035^1.103

 +68      ;;89084^1.005^1.035^1.103

 +69      ;;89086^1.005^1.035^1.103

 +70      ;;91387^1.055^1.169^0.901

 +71      ;;91390^1.055^1.169^0.901

 +72      ;;92637^1.036^1.187^0.901

 +73      ;;92809^1.036^1.187^0.901

 +74      ;;94303^1.062^1.321^0.653

 +75      ;;95033^1.007^1.039^0.723

 +76      ;;98082^0.982^0.974^0.765

 +77      ;;00727^0.882^0.72^0.317

 +78      ;;03258^0.987^1.032^0.919

 +79      ;;07086^1.057^1.192^0.827

 +80      ;;08205^1.028^1.102^0.827

 +81      ;;END

 +82      ;

 +83      ;FBXIP33