XIPSRVR ;SFISC/SO- SERVER TO UPDATE THE POSTAL CODE(#5.12) FILE ;3/12/13
;;8.0;KERNEL;**449,625**;Jul 10, 1995;Build 4
;;Per VHA Directive 2004-038, this routine should not be modified.
Q
;
E1 ;
N LN,ESC,XIPSEED,ACNT,ECNT,ICNT,LCNT,TREC,NECNT
S (LN,ESC,ACNT,ECNT,ICNT,TREC,NECNT)=0,LCNT=9
K ^TMP("XIP DATA",$J)
S ^TMP("XIP DATA",$J)=""
S ^TMP("XIP DATA",$J,LCNT)=" ",LCNT=LCNT+1
S ^TMP("XIP DATA",$J,LCNT)=" **Detail Changes**",LCNT=LCNT+1
S ^TMP("XIP DATA",$J,LCNT)="IEN^MAIL CODE^CITY^COUNTY^STATE^INACTIVE DATE^CITY KEY^PREFERRED CITY KEY^CITY ABBREVIATION^UNIQUE KEY (VA)^FLAG",LCNT=LCNT+1
S XIPSEED=1 ; XIPSEED set to prevent "AD" from being set
;
; XQMSG is passed via the Server option
; See Kernel Programmer, Page: 19-1
; "Key Variables When a Server Option is Running"
;
F S LN=$O(^XMB(3.9,XQMSG,2,LN)) Q:'LN D Q:ESC
. I LN<1 Q
. N DATA,IEN,LKUP
. S DATA=^XMB(3.9,XQMSG,2,LN,0)
. I LN=1,DATA'="$$DATA$$" S ESC=1 Q
. I DATA="$$EOD$$" S TREC=$O(^XMB(3.9,XQMSG,2," "),-1),TREC=TREC-2,ESC=1 Q
. I DATA="$$DATA$$" Q
. I DATA="$$EOD$$" Q
. ;
. S LKUP=$P(DATA,U,9) ; UNIQUE KEY
. S IEN=+$O(^XIP(5.12,"E",LKUP,0))
ADD . ;
. I 'IEN D Q ; New ZIP Code
.. N FIPSPTR,STPTR,Y
.. S FIPSPTR=0,STPTR=0
.. S FIPSPTR=+$O(^XIP(5.13,"B",$P(DATA,U,3),0))
.. I 'FIPSPTR Q ;Broken FIPS
.. S STPTR=+$O(^DIC(5,"B",$P(DATA,U,4),0))
.. I 'STPTR Q ;Broken STATE
.. N DO,DIC,X
.. S DIC="^XIP(5.12,",DIC(0)="Z",X=$P(DATA,U,1) D FILE^DICN
.. I Y<1 Q
.. N DA,DIE,DR
.. S DA=+Y,DIE=DIC
.. S DR="1///^S X=$P(DATA,U,2);2///^S X=""`""_FIPSPTR;3///^S X=""`""_STPTR;"
.. S DR=DR_"5///^S X=$P(DATA,U,6);6///^S X=$P(DATA,U,7);7///^S X=$P(DATA,U,8)"
.. F L +^XIP(5.12,DA,0):$S($D(DILOCKTM):DILOCKTM,1:3) Q:$T H $S($D(DILOCKTM):DILOCKTM,1:3)
.. D ^DIE
.. L -^XIP(5.12,DA,0)
.. S ACNT=ACNT+1
.. S ^TMP("XIP DATA",$J,LCNT)=DA_U_DATA_U_"New",LCNT=LCNT+1
.. Q
INACT . ;
. I $P(DATA,U,5)'="" D Q ; INACTIVE DATE
.. I $P(^XIP(5.12,IEN,0),U,5)'="" S NECNT=NECNT+1 Q ;Already has Inactive Date
.. N DIE,DA,DR
.. S DIE="^XIP(5.12,",DA=IEN,DR="4///^S X=$P(DATA,U,5)"
.. F L +^XIP(5.12,DA,0):$S($D(DILOCKTM):DILOCKTM,1:3) Q:$T H $S($D(DILOCKTM):DILOCKTM,1:3)
.. D ^DIE
.. L -^XIP(5.12,DA,0)
.. S ICNT=ICNT+1
.. S ^TMP("XIP DATA",$J,LCNT)=DA_U_DATA_U_"Inactivated",LCNT=LCNT+1
.. Q
EDIT . ;
. D Q ; Edited Entry
.. N FIPSPTR,STPTR,FDATA
.. S FIPSPTR=0,STPTR=0
.. S FIPSPTR=+$O(^XIP(5.13,"B",$P(DATA,U,3),0))
.. I 'FIPSPTR Q ;Broken FIPS
.. S STPTR=+$O(^DIC(5,"B",$P(DATA,U,4),0))
.. I 'STPTR Q ;Broken STATE
.. S FDATA=^XIP(5.12,IEN,0)
.. S $P(FDATA,U,3)=$P(^XIP(5.13,$P(FDATA,U,3),0),U) ;Resolve COUNTY CODE
.. S $P(FDATA,U,4)=$P(^DIC(5,$P(FDATA,U,4),0),U) ;Resolve STATE
.. I DATA=FDATA S NECNT=NECNT+1 Q ;Already been edited
.. N DA,DIE,DR
.. S DA=IEN,DIE="^XIP(5.12,"
.. S DR="1///^S X=$P(DATA,U,2);2///^S X=""`""_FIPSPTR;3///^S X=""`""_STPTR;"
.. I $P(DATA,U,5)="" S DR=DR_"4///^S X=""@"";" ;Ba added to reactivate a Postal code. P625
.. S DR=DR_"5///^S X=$P(DATA,U,6);6///^S X=$P(DATA,U,7);7///^S X=$P(DATA,U,8)"
.. F L +^XIP(5.12,DA,0):$S($D(DILOCKTM):DILOCKTM,1:3) Q:$T H $S($D(DILOCKTM):DILOCKTM,1:3)
.. D ^DIE
.. L -^XIP(5.12,DA,0)
.. S ECNT=ECNT+1
.. S ^TMP("XIP DATA",$J,LCNT)=DA_U_DATA_U_"Edited",LCNT=LCNT+1
.. Q
. Q
;
END ;
N TOT S TOT=ACNT+ICNT+ECNT
I 'TOT K ^TMP("XIP DATA",$J)
S LCNT=1
S ^TMP("XIP DATA",$J,LCNT)=" ",LCNT=LCNT+1
S ^TMP("XIP DATA",$J,LCNT)="*Summary for this Update*",LCNT=LCNT+1
S ^TMP("XIP DATA",$J,LCNT)="Total Data Records: "_TREC,LCNT=LCNT+1
S ^TMP("XIP DATA",$J,LCNT)="Unedited Records: "_NECNT,LCNT=LCNT+1
S ^TMP("XIP DATA",$J,LCNT)="New ZIP Codes: "_ACNT,LCNT=LCNT+1
S ^TMP("XIP DATA",$J,LCNT)="Inactivated ZIP Codes: "_ICNT,LCNT=LCNT+1
S ^TMP("XIP DATA",$J,LCNT)="Edited ZIP Codes: "_ECNT,LCNT=LCNT+1
S ^TMP("XIP DATA",$J,LCNT)="Total Changes: "_TOT,LCNT=LCNT+1
I 'TOT D
. S ^TMP("XIP DATA",$J,LCNT)="**Your POSTAL CODE(#5.12) file is current with the Master",LCNT=LCNT+1
. S ^TMP("XIP DATA",$J,LCNT)=" POSTAL CODE(#5.12) file.",LCNT=LCNT+1
. Q
;
SEND ; Send 'Results' message If & Only If there are MEMBERS
I $$GOTLOCAL^XMXAPIG("XIP POSTAL CODE UPDATE") D
. N MSGSBJ,ODUZ,MSG,WHO
. S MSG=$NA(^TMP("XIP DATA",$J))
. I DUZ<.5 S ODUZ=DUZ,DUZ=.5 ;** Change user to POSTMASTER **
. S MSGSBJ="POSTAL CODE(#5.12) File Update Results"
. S WHO("G.XIP POSTAL CODE UPDATE")=""
. D SENDMSG^XMXAPI(DUZ,MSGSBJ,.MSG,.WHO)
. I $G(ODUZ)'="" S DUZ=ODUZ ;** Change POSTMASTER back to current user **
. Q
K ^TMP("XIP DATA",$J) ; p461
Q
;
POST ;
N XU625
S XU625=$G(^XIP(5.12,52000,0))
I $P(XU625,"^",1,2)="34607^SPRING HILL" D REACT(52000,"@","34607 SPRING HILL")
S XU625=$G(^XIP(5.12,52003,0))
I $P(XU625,"^",1,2)="34610^SPRING HILL" D REACT(52003,"@","34610 SPRING HILL")
D DEL
Q
;
REACT(IEN,DATA,POSTAL) ;
N DIE,DA,DR
S DIE="^XIP(5.12,",DA=IEN,DR="4///^S X=DATA"
F L +^XIP(5.12,DA,0):$S($D(DILOCKTM):DILOCKTM,1:3) Q:$T H $S($D(DILOCKTM):DILOCKTM,1:3)
D MES^XPDUTL("Reactivate Postal Code "_POSTAL)
D ^DIE
L -^XIP(5.12,DA,0)
Q
;
DEL ;
;D MES^XPDUTL("Deleting ""AD"" Cross Reference")
K ^XIP(5.12,"AD")
;D MES^XPDUTL("Finished Deleting the ""AD"" Cross Reference")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXIPSRVR 5345 printed Apr 09, 2024@21:06:45 Page 2
XIPSRVR ;SFISC/SO- SERVER TO UPDATE THE POSTAL CODE(#5.12) FILE ;3/12/13
+1 ;;8.0;KERNEL;**449,625**;Jul 10, 1995;Build 4
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 QUIT
+4 ;
E1 ;
+1 NEW LN,ESC,XIPSEED,ACNT,ECNT,ICNT,LCNT,TREC,NECNT
+2 SET (LN,ESC,ACNT,ECNT,ICNT,TREC,NECNT)=0
SET LCNT=9
+3 KILL ^TMP("XIP DATA",$JOB)
+4 SET ^TMP("XIP DATA",$JOB)=""
+5 SET ^TMP("XIP DATA",$JOB,LCNT)=" "
SET LCNT=LCNT+1
+6 SET ^TMP("XIP DATA",$JOB,LCNT)=" **Detail Changes**"
SET LCNT=LCNT+1
+7 SET ^TMP("XIP DATA",$JOB,LCNT)="IEN^MAIL CODE^CITY^COUNTY^STATE^INACTIVE DATE^CITY KEY^PREFERRED CITY KEY^CITY ABBREVIATION^UNIQUE KEY (VA)^FLAG"
SET LCNT=LCNT+1
+8 ; XIPSEED set to prevent "AD" from being set
SET XIPSEED=1
+9 ;
+10 ; XQMSG is passed via the Server option
+11 ; See Kernel Programmer, Page: 19-1
+12 ; "Key Variables When a Server Option is Running"
+13 ;
+14 FOR
SET LN=$ORDER(^XMB(3.9,XQMSG,2,LN))
if 'LN
QUIT
Begin DoDot:1
+15 IF LN<1
QUIT
+16 NEW DATA,IEN,LKUP
+17 SET DATA=^XMB(3.9,XQMSG,2,LN,0)
+18 IF LN=1
IF DATA'="$$DATA$$"
SET ESC=1
QUIT
+19 IF DATA="$$EOD$$"
SET TREC=$ORDER(^XMB(3.9,XQMSG,2," "),-1)
SET TREC=TREC-2
SET ESC=1
QUIT
+20 IF DATA="$$DATA$$"
QUIT
+21 IF DATA="$$EOD$$"
QUIT
+22 ;
+23 ; UNIQUE KEY
SET LKUP=$PIECE(DATA,U,9)
+24 SET IEN=+$ORDER(^XIP(5.12,"E",LKUP,0))
ADD ;
+1 ; New ZIP Code
IF 'IEN
Begin DoDot:2
+2 NEW FIPSPTR,STPTR,Y
+3 SET FIPSPTR=0
SET STPTR=0
+4 SET FIPSPTR=+$ORDER(^XIP(5.13,"B",$PIECE(DATA,U,3),0))
+5 ;Broken FIPS
IF 'FIPSPTR
QUIT
+6 SET STPTR=+$ORDER(^DIC(5,"B",$PIECE(DATA,U,4),0))
+7 ;Broken STATE
IF 'STPTR
QUIT
+8 NEW DO,DIC,X
+9 SET DIC="^XIP(5.12,"
SET DIC(0)="Z"
SET X=$PIECE(DATA,U,1)
DO FILE^DICN
+10 IF Y<1
QUIT
+11 NEW DA,DIE,DR
+12 SET DA=+Y
SET DIE=DIC
+13 SET DR="1///^S X=$P(DATA,U,2);2///^S X=""`""_FIPSPTR;3///^S X=""`""_STPTR;"
+14 SET DR=DR_"5///^S X=$P(DATA,U,6);6///^S X=$P(DATA,U,7);7///^S X=$P(DATA,U,8)"
+15 FOR
LOCK +^XIP(5.12,DA,0):$SELECT($DATA(DILOCKTM):DILOCKTM,1:3)
if $TEST
QUIT
HANG $SELECT($DATA(DILOCKTM):DILOCKTM,1:3)
+16 DO ^DIE
+17 LOCK -^XIP(5.12,DA,0)
+18 SET ACNT=ACNT+1
+19 SET ^TMP("XIP DATA",$JOB,LCNT)=DA_U_DATA_U_"New"
SET LCNT=LCNT+1
+20 QUIT
End DoDot:2
QUIT
INACT ;
+1 ; INACTIVE DATE
IF $PIECE(DATA,U,5)'=""
Begin DoDot:2
+2 ;Already has Inactive Date
IF $PIECE(^XIP(5.12,IEN,0),U,5)'=""
SET NECNT=NECNT+1
QUIT
+3 NEW DIE,DA,DR
+4 SET DIE="^XIP(5.12,"
SET DA=IEN
SET DR="4///^S X=$P(DATA,U,5)"
+5 FOR
LOCK +^XIP(5.12,DA,0):$SELECT($DATA(DILOCKTM):DILOCKTM,1:3)
if $TEST
QUIT
HANG $SELECT($DATA(DILOCKTM):DILOCKTM,1:3)
+6 DO ^DIE
+7 LOCK -^XIP(5.12,DA,0)
+8 SET ICNT=ICNT+1
+9 SET ^TMP("XIP DATA",$JOB,LCNT)=DA_U_DATA_U_"Inactivated"
SET LCNT=LCNT+1
+10 QUIT
End DoDot:2
QUIT
EDIT ;
+1 ; Edited Entry
Begin DoDot:2
+2 NEW FIPSPTR,STPTR,FDATA
+3 SET FIPSPTR=0
SET STPTR=0
+4 SET FIPSPTR=+$ORDER(^XIP(5.13,"B",$PIECE(DATA,U,3),0))
+5 ;Broken FIPS
IF 'FIPSPTR
QUIT
+6 SET STPTR=+$ORDER(^DIC(5,"B",$PIECE(DATA,U,4),0))
+7 ;Broken STATE
IF 'STPTR
QUIT
+8 SET FDATA=^XIP(5.12,IEN,0)
+9 ;Resolve COUNTY CODE
SET $PIECE(FDATA,U,3)=$PIECE(^XIP(5.13,$PIECE(FDATA,U,3),0),U)
+10 ;Resolve STATE
SET $PIECE(FDATA,U,4)=$PIECE(^DIC(5,$PIECE(FDATA,U,4),0),U)
+11 ;Already been edited
IF DATA=FDATA
SET NECNT=NECNT+1
QUIT
+12 NEW DA,DIE,DR
+13 SET DA=IEN
SET DIE="^XIP(5.12,"
+14 SET DR="1///^S X=$P(DATA,U,2);2///^S X=""`""_FIPSPTR;3///^S X=""`""_STPTR;"
+15 ;Ba added to reactivate a Postal code. P625
IF $PIECE(DATA,U,5)=""
SET DR=DR_"4///^S X=""@"";"
+16 SET DR=DR_"5///^S X=$P(DATA,U,6);6///^S X=$P(DATA,U,7);7///^S X=$P(DATA,U,8)"
+17 FOR
LOCK +^XIP(5.12,DA,0):$SELECT($DATA(DILOCKTM):DILOCKTM,1:3)
if $TEST
QUIT
HANG $SELECT($DATA(DILOCKTM):DILOCKTM,1:3)
+18 DO ^DIE
+19 LOCK -^XIP(5.12,DA,0)
+20 SET ECNT=ECNT+1
+21 SET ^TMP("XIP DATA",$JOB,LCNT)=DA_U_DATA_U_"Edited"
SET LCNT=LCNT+1
+22 QUIT
End DoDot:2
QUIT
+23 QUIT
End DoDot:1
if ESC
QUIT
+24 ;
END ;
+1 NEW TOT
SET TOT=ACNT+ICNT+ECNT
+2 IF 'TOT
KILL ^TMP("XIP DATA",$JOB)
+3 SET LCNT=1
+4 SET ^TMP("XIP DATA",$JOB,LCNT)=" "
SET LCNT=LCNT+1
+5 SET ^TMP("XIP DATA",$JOB,LCNT)="*Summary for this Update*"
SET LCNT=LCNT+1
+6 SET ^TMP("XIP DATA",$JOB,LCNT)="Total Data Records: "_TREC
SET LCNT=LCNT+1
+7 SET ^TMP("XIP DATA",$JOB,LCNT)="Unedited Records: "_NECNT
SET LCNT=LCNT+1
+8 SET ^TMP("XIP DATA",$JOB,LCNT)="New ZIP Codes: "_ACNT
SET LCNT=LCNT+1
+9 SET ^TMP("XIP DATA",$JOB,LCNT)="Inactivated ZIP Codes: "_ICNT
SET LCNT=LCNT+1
+10 SET ^TMP("XIP DATA",$JOB,LCNT)="Edited ZIP Codes: "_ECNT
SET LCNT=LCNT+1
+11 SET ^TMP("XIP DATA",$JOB,LCNT)="Total Changes: "_TOT
SET LCNT=LCNT+1
+12 IF 'TOT
Begin DoDot:1
+13 SET ^TMP("XIP DATA",$JOB,LCNT)="**Your POSTAL CODE(#5.12) file is current with the Master"
SET LCNT=LCNT+1
+14 SET ^TMP("XIP DATA",$JOB,LCNT)=" POSTAL CODE(#5.12) file."
SET LCNT=LCNT+1
+15 QUIT
End DoDot:1
+16 ;
SEND ; Send 'Results' message If & Only If there are MEMBERS
+1 IF $$GOTLOCAL^XMXAPIG("XIP POSTAL CODE UPDATE")
Begin DoDot:1
+2 NEW MSGSBJ,ODUZ,MSG,WHO
+3 SET MSG=$NAME(^TMP("XIP DATA",$JOB))
+4 ;** Change user to POSTMASTER **
IF DUZ<.5
SET ODUZ=DUZ
SET DUZ=.5
+5 SET MSGSBJ="POSTAL CODE(#5.12) File Update Results"
+6 SET WHO("G.XIP POSTAL CODE UPDATE")=""
+7 DO SENDMSG^XMXAPI(DUZ,MSGSBJ,.MSG,.WHO)
+8 ;** Change POSTMASTER back to current user **
IF $GET(ODUZ)'=""
SET DUZ=ODUZ
+9 QUIT
End DoDot:1
+10 ; p461
KILL ^TMP("XIP DATA",$JOB)
+11 QUIT
+12 ;
POST ;
+1 NEW XU625
+2 SET XU625=$GET(^XIP(5.12,52000,0))
+3 IF $PIECE(XU625,"^",1,2)="34607^SPRING HILL"
DO REACT(52000,"@","34607 SPRING HILL")
+4 SET XU625=$GET(^XIP(5.12,52003,0))
+5 IF $PIECE(XU625,"^",1,2)="34610^SPRING HILL"
DO REACT(52003,"@","34610 SPRING HILL")
+6 DO DEL
+7 QUIT
+8 ;
REACT(IEN,DATA,POSTAL) ;
+1 NEW DIE,DA,DR
+2 SET DIE="^XIP(5.12,"
SET DA=IEN
SET DR="4///^S X=DATA"
+3 FOR
LOCK +^XIP(5.12,DA,0):$SELECT($DATA(DILOCKTM):DILOCKTM,1:3)
if $TEST
QUIT
HANG $SELECT($DATA(DILOCKTM):DILOCKTM,1:3)
+4 DO MES^XPDUTL("Reactivate Postal Code "_POSTAL)
+5 DO ^DIE
+6 LOCK -^XIP(5.12,DA,0)
+7 QUIT
+8 ;
DEL ;
+1 ;D MES^XPDUTL("Deleting ""AD"" Cross Reference")
+2 KILL ^XIP(5.12,"AD")
+3 ;D MES^XPDUTL("Finished Deleting the ""AD"" Cross Reference")
+4 QUIT
