Routine: ACRF14PS

ACRF14PS ;IHS/PHXAO/AEF - ARMS PATCH 14 POST INSTALL ROUTINE [ 10/28/2004  11:08 AM ]

 ;;2.1;ADMINISTRATIVE RESOURCE MGMT SYSTEM;**14**;MAY 27, 2004

EN ;EP -- MAIN ENTRY POINT

 D ^XBKVAR

 D HOME^%ZIS

 D COMPP

 D COMPC

 D POPCLC

COMPP ;----- RECOMPILE PRINT TEMPLATES

 N ACRPTEMP,I,X

 D BMES^XPDUTL("Recompiling print templates...")

 F I=1:1 S X=$T(PTEMP+I) Q:X["$$END"  S ACRPTEMP($P(X,";;",2))=""

 S ACRPTEMP=""

 F  S ACRPTEMP=$O(ACRPTEMP(ACRPTEMP)) Q:ACRPTEMP']""  D

 . D ONEP(ACRPTEMP)

ONEP(ACRPTEMP)     ;

 ;----- RECOMPILE ONE PRINT TEMPLATE

 ;      ACRPTEMP  =  PRINT TEMPLATE NAME

 N ACRFILE,ACRIEN,DMAX,X,Y

 S ACRFILE=$P(ACRPTEMP,U,2)

 S ACRPTEMP=$P(ACRPTEMP,U)

 S ACRIEN=0

 F  S ACRIEN=$O(^DIPT("B",ACRPTEMP,ACRIEN)) Q:'ACRIEN  D

 . Q:$P($G(^DIPT(ACRIEN,0)),U,4)'=ACRFILE

 . S X=$P($G(^DIPT(ACRIEN,"ROU")),U,2)

 . Q:X']""

 . S Y=ACRIEN

 . S DMAX=$$ROUSIZE^DILF

 . D EN^DIPZ

COMPC ;----- COMPILE CROSSREFERENCES

 N DMAX,X,Y

 S Y=9002196

 S X=$G(^DD(Y,0,"DIK"))

 Q:X']""

 S DMAX=$$ROUSIZE^DILF

 D EN^DIKZ

POPCLC ;----- POPULATE CONTRACT LOCATION CODE AND TURN ON EXPANDED DOCUMENT

 ;      NUMBER PRINTING

 N ACRCLC,DA,DIE,DR,X,Y

 D BMES^XPDUTL("Entering Contract Location Code...")

 D BMES^XPDUTL("Turning on Expanded Document Number printing...")

 S ACRCLC=$$CLC($$HOST)

 I 'ACRCLC D  Q

 . D BMES^XPDUTL(">>> Cannot find Contract Location Code")

 . D BMES^XPDUTL(">>> Cannot turn on Expanded Document Number printing")

 . D BMES^XPDUTL(">>> Please update FMS System Defaults file manually")

 S DIE="^ACRSYS("

 S DA=1

 S DR="601.1///^S X=ACRCLC;601.2////^S X=1"

 D ^DIE

HOST() ;----- RETURNS HOST NAME FROM RPMS SITE FILE

N Y

 S Y=""

 S Y=$P($G(^AUTTSITE(1,0)),U,14)

 S Y=$TR(Y,"-")

Q Y

CLC(X) ;----- RETURNS CONTRACT LOCATION CODE

 ;      X  =  AREA HOST NAME

N Y

 S Y=""

 S X=$E(X,1,3)

 X ^%ZOSF("UPPERCASE")

 S X=Y

 S Y=""

 I X="ABR" S Y=241

 I X="AKA" S Y=243

 I X="ALB" S Y=242

 I X="BIL" S Y=244

 I X="BJI" S Y=239

 I X="CAO" S Y=235

 I X="CMB" S Y=242

 I X="DPS" S Y=236

 I X="NAV" S Y=245

 I X="NSA" S Y=285

 I X="OKC" S Y=246

 I X="PHX" S Y=247

 I X="POR" S Y=248

 I X="TUC" S Y=249

Q Y

PTEMP ;----- PRINT TEMPLATES TO BE COMPILED

 ;;ACR BPA^9002196

 ;;ACR EQUIPMENT CERTIFICATION^9002196

 ;;ACR ORDER FOR SUP HEAD^9002196

 ;;ACR ORDER FOR SUP/SER^9002196

 ;;ACR PURCHASE ORDER AMENDMENT^9002196

 ;;ACR PURCHASE ORDER HEAD^9002196

 ;;ACR PURCHASE ORDER INFO^9002196

 ;;ACR PURCHASE ORDER INFO HEAD^9002196

 ;;ACR RECEIVING REPORT^9002196

 ;;ACR RECEIVING REPORT HEAD^9002196

 ;;ACR REQUEST FOR QUOTATION-H^9002196

 ;;ACR REQUISITION-TX^9002196

 ;;ACR SEPARATE TRAVEL ITINERARY^9002196

 ;;ACR TRAINING 350^9002196

 ;;ACR TRAINING EVALUATION^9002191.6

 ;;ACR TRAVEL ITINERARY^9002196

 ;;ACR TRAVEL ORDER^9002196

 ;;ACR TRAVEL ORDER HEAD^9002196

 ;;ACR TRAVEL ORDER SUMMARY^9002196

 ;;ACR TRAVEL VOUCHER^9002196

 ;;ACR TRAVEL VOUCHER SUMMARY^9002196

 ;;$$END

ACRF14PS  ;IHS/PHXAO/AEF - ARMS PATCH 14 POST INSTALL ROUTINE [ 10/28/2004  11:08 AM ]

 +1       ;;2.1;ADMINISTRATIVE RESOURCE MGMT SYSTEM;**14**;MAY 27, 2004

 +2       ;

EN        ;EP -- MAIN ENTRY POINT

 +1       ;

 +2        DO ^XBKVAR

 +3        DO HOME^%ZIS

 +4        DO COMPP

 +5        DO COMPC

 +6        DO POPCLC

 +7        QUIT

COMPP     ;----- RECOMPILE PRINT TEMPLATES

 +1       ;

 +2        NEW ACRPTEMP,I,X

 +3       ;

 +4        DO BMES^XPDUTL("Recompiling print templates...")

 +5       ;

 +6        FOR I=1:1

               SET X=$TEXT(PTEMP+I)

               IF X["$$END"

                   QUIT

               SET ACRPTEMP($PIECE(X,";;",2))=""

 +7       ;

 +8        SET ACRPTEMP=""

 +9        FOR

               SET ACRPTEMP=$ORDER(ACRPTEMP(ACRPTEMP))

               IF ACRPTEMP']""

                   QUIT

               Begin DoDot:1

 +10               DO ONEP(ACRPTEMP)

               End DoDot:1

 +11       QUIT

ONEP(ACRPTEMP) ;

 +1       ;----- RECOMPILE ONE PRINT TEMPLATE

 +2       ;

 +3       ;      ACRPTEMP  =  PRINT TEMPLATE NAME

 +4       ;

 +5        NEW ACRFILE,ACRIEN,DMAX,X,Y

 +6       ;

 +7        SET ACRFILE=$PIECE(ACRPTEMP,U,2)

 +8        SET ACRPTEMP=$PIECE(ACRPTEMP,U)

 +9        SET ACRIEN=0

 +10       FOR

               SET ACRIEN=$ORDER(^DIPT("B",ACRPTEMP,ACRIEN))

               IF 'ACRIEN

                   QUIT

               Begin DoDot:1

 +11               IF $PIECE($GET(^DIPT(ACRIEN,0)),U,4)'=ACRFILE

                       QUIT

 +12               SET X=$PIECE($GET(^DIPT(ACRIEN,"ROU")),U,2)

 +13               IF X']""

                       QUIT

 +14               SET Y=ACRIEN

 +15               SET DMAX=$$ROUSIZE^DILF

 +16               DO EN^DIPZ

               End DoDot:1

 +17       QUIT

COMPC     ;----- COMPILE CROSSREFERENCES

 +1       ;

 +2        NEW DMAX,X,Y

 +3       ;

 +4        SET Y=9002196

 +5        SET X=$GET(^DD(Y,0,"DIK"))

 +6        IF X']""

               QUIT

 +7        SET DMAX=$$ROUSIZE^DILF

 +8        DO EN^DIKZ

 +9        QUIT

POPCLC    ;----- POPULATE CONTRACT LOCATION CODE AND TURN ON EXPANDED DOCUMENT

 +1       ;      NUMBER PRINTING

 +2       ;

 +3        NEW ACRCLC,DA,DIE,DR,X,Y

 +4       ;

 +5        DO BMES^XPDUTL("Entering Contract Location Code...")

 +6        DO BMES^XPDUTL("Turning on Expanded Document Number printing...")

 +7       ;

 +8        SET ACRCLC=$$CLC($$HOST)

 +9        IF 'ACRCLC

               Begin DoDot:1

 +10               DO BMES^XPDUTL(">>> Cannot find Contract Location Code")

 +11               DO BMES^XPDUTL(">>> Cannot turn on Expanded Document Number printing")

 +12               DO BMES^XPDUTL(">>> Please update FMS System Defaults file manually")

               End DoDot:1

               QUIT

 +13      ;

 +14       SET DIE="^ACRSYS("

 +15       SET DA=1

 +16       SET DR="601.1///^S X=ACRCLC;601.2////^S X=1"

 +17       DO ^DIE

 +18      ;

 +19       QUIT

HOST()    ;----- RETURNS HOST NAME FROM RPMS SITE FILE

 +1       ;

 +2        NEW Y

 +3        SET Y=""

 +4        SET Y=$PIECE($GET(^AUTTSITE(1,0)),U,14)

 +5        SET Y=$TRANSLATE(Y,"-")

 +6        QUIT Y

CLC(X)    ;----- RETURNS CONTRACT LOCATION CODE

 +1       ;

 +2       ;      X  =  AREA HOST NAME

 +3       ;

 +4        NEW Y

 +5        SET Y=""

 +6        SET X=$EXTRACT(X,1,3)

 +7        XECUTE ^%ZOSF("UPPERCASE")

 +8        SET X=Y

 +9        SET Y=""

 +10       IF X="ABR"

               SET Y=241

 +11       IF X="AKA"

               SET Y=243

 +12       IF X="ALB"

               SET Y=242

 +13       IF X="BIL"

               SET Y=244

 +14       IF X="BJI"

               SET Y=239

 +15       IF X="CAO"

               SET Y=235

 +16       IF X="CMB"

               SET Y=242

 +17       IF X="DPS"

               SET Y=236

 +18       IF X="NAV"

               SET Y=245

 +19       IF X="NSA"

               SET Y=285

 +20       IF X="OKC"

               SET Y=246

 +21       IF X="PHX"

               SET Y=247

 +22       IF X="POR"

               SET Y=248

 +23       IF X="TUC"

               SET Y=249

 +24       QUIT Y

PTEMP     ;----- PRINT TEMPLATES TO BE COMPILED

 +1       ;;ACR BPA^9002196

 +2       ;;ACR EQUIPMENT CERTIFICATION^9002196

 +3       ;;ACR ORDER FOR SUP HEAD^9002196

 +4       ;;ACR ORDER FOR SUP/SER^9002196

 +5       ;;ACR PURCHASE ORDER AMENDMENT^9002196

 +6       ;;ACR PURCHASE ORDER HEAD^9002196

 +7       ;;ACR PURCHASE ORDER INFO^9002196

 +8       ;;ACR PURCHASE ORDER INFO HEAD^9002196

 +9       ;;ACR RECEIVING REPORT^9002196

 +10      ;;ACR RECEIVING REPORT HEAD^9002196

 +11      ;;ACR REQUEST FOR QUOTATION-H^9002196

 +12      ;;ACR REQUISITION-TX^9002196

 +13      ;;ACR SEPARATE TRAVEL ITINERARY^9002196

 +14      ;;ACR TRAINING 350^9002196

 +15      ;;ACR TRAINING EVALUATION^9002191.6

 +16      ;;ACR TRAVEL ITINERARY^9002196

 +17      ;;ACR TRAVEL ORDER^9002196

 +18      ;;ACR TRAVEL ORDER HEAD^9002196

 +19      ;;ACR TRAVEL ORDER SUMMARY^9002196

 +20      ;;ACR TRAVEL VOUCHER^9002196

 +21      ;;ACR TRAVEL VOUCHER SUMMARY^9002196

 +22      ;;$$END

ACRF14PS.m