DGYPREG5 ;ALB/REW - ZIP+4 POST-INIT CONVERSION ;4-JUN-93
;;5.3;Registration;;Aug 13, 1993
;
QUEZIP4 ;
S ZTRTN="ZIP4PT^DGYPREG5",ZTDESC="PIMS 5.3 ZIP+4 CONVERSION",ZTIO=""
D ^%ZTLOAD
Q
ZIP4PT ;
N DFN
S DFN=0
W:'$D(ZTQUEUED) !,">>> Populating ZIP+4 fields...",!
F S DFN=$O(^DPT(DFN)) Q:'DFN W:'(DFN#100)&('$D(ZTQUEUED)) "." D MAKEZIP4(DFN) D DISPZIP(DFN)
W:'$D(ZTQUEUED) !!,"...ZIP+4 CONVERSION DONE "
D SETUP^DGYPREG1(3)
G:'$D(ZTQUEUED) QTZ4PT
S DGXM=1 ;message line number
D MESS^DGYPREG1("The Population of the following ZIP+4 fields is complete (Field #'s):")
D MESS^DGYPREG1(".2201,.2202,.2203,.2204,.2205,.2206,.2207,.12112,.290012,.29013,.1112",1)
D MESS^DGYPREG1("PIMS will use the above fields instead of the following ZIP CODE list:")
D MESS^DGYPREG1(".338,.348,.2198,.3318,.3118,.257,.218,.1216,.2928,.2918,.116",1)
D MESS^DGYPREG1(" - Also sub-field #38 of the DISPOSITION multiple is populated (A-ZIP+4)")
D MESS^DGYPREG1(" it will be used instead of subfield #36 (A-ZIP CODE)",1)
D END^DGYPREG1
QTZ4PT Q
DISPZIP(DFN) ;Populates the attorney's zip+4 in disposition multiple
N DFN1
S DFN1=0
F S DFN1=$O(^DPT(DFN,"DIS",DFN1)) Q:'DFN1 D
.S:$P($G(^DPT(DFN,"DIS",DFN1,3)),U,7)&($P($G(^DPT(DFN,"DIS",DFN1,3)),U,7)']"") $P(^(3),U,9)=$P(^(3),U,7)
Q
MAKEZIP4(DFN) ;Populates zip+4 fields with zip code fields
;ZIP->ZIP+4
D FROMTO(DFN,.33,8,.22,1)
D FROMTO(DFN,.34,8,.22,2)
D FROMTO(DFN,.211,8,.22,3)
D FROMTO(DFN,.331,8,.22,4)
D FROMTO(DFN,.311,8,.22,5)
D FROMTO(DFN,.25,7,.22,6)
D FROMTO(DFN,.21,8,.22,7)
D FROMTO(DFN,.121,6,.121,12)
D FROMTO(DFN,.291,10,.291,12)
D FROMTO(DFN,.29,10,.29,13)
D FROMTO(DFN,.11,6,.11,12)
Q
FROMTO(DFN,FROMNODE,FROMPC,TONODE,TOPC) ;POPULATES ZIP+4 WITH ZIP DATA
;VARIABLES:
; DFN - IEN of Patient File
;FROMNODE - zip code node
;TONODE - zip+4 node
;FROMPC - zip code piece
;TOPC -zip+4 piece
;
I '$G(DFN)!('$G(FROMNODE))!('$G(FROMPC))!('$G(TONODE))!('$G(TOPC)) D Q
.W:'$D(ZTQUEUED) !,"MISSING INPUT VARIABLE"
I $P($G(^DPT(DFN,FROMNODE)),U,FROMPC) D
.S:'$P($G(^DPT(DFN,TONODE)),U,TOPC) $P(^DPT(DFN,TONODE),U,TOPC)=$P(^DPT(DFN,FROMNODE),U,FROMPC)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGYPREG5 2207 printed Sep 23, 2025@20:36:27 Page 2
DGYPREG5 ;ALB/REW - ZIP+4 POST-INIT CONVERSION ;4-JUN-93
+1 ;;5.3;Registration;;Aug 13, 1993
+2 ;
QUEZIP4 ;
+1 SET ZTRTN="ZIP4PT^DGYPREG5"
SET ZTDESC="PIMS 5.3 ZIP+4 CONVERSION"
SET ZTIO=""
+2 DO ^%ZTLOAD
+3 QUIT
ZIP4PT ;
+1 NEW DFN
+2 SET DFN=0
+3 if '$DATA(ZTQUEUED)
WRITE !,">>> Populating ZIP+4 fields...",!
+4 FOR
SET DFN=$ORDER(^DPT(DFN))
if 'DFN
QUIT
if '(DFN#100)&('$DATA(ZTQUEUED))
WRITE "."
DO MAKEZIP4(DFN)
DO DISPZIP(DFN)
+5 if '$DATA(ZTQUEUED)
WRITE !!,"...ZIP+4 CONVERSION DONE "
+6 DO SETUP^DGYPREG1(3)
+7 if '$DATA(ZTQUEUED)
GOTO QTZ4PT
+8 ;message line number
SET DGXM=1
+9 DO MESS^DGYPREG1("The Population of the following ZIP+4 fields is complete (Field #'s):")
+10 DO MESS^DGYPREG1(".2201,.2202,.2203,.2204,.2205,.2206,.2207,.12112,.290012,.29013,.1112",1)
+11 DO MESS^DGYPREG1("PIMS will use the above fields instead of the following ZIP CODE list:")
+12 DO MESS^DGYPREG1(".338,.348,.2198,.3318,.3118,.257,.218,.1216,.2928,.2918,.116",1)
+13 DO MESS^DGYPREG1(" - Also sub-field #38 of the DISPOSITION multiple is populated (A-ZIP+4)")
+14 DO MESS^DGYPREG1(" it will be used instead of subfield #36 (A-ZIP CODE)",1)
+15 DO END^DGYPREG1
QTZ4PT QUIT
DISPZIP(DFN) ;Populates the attorney's zip+4 in disposition multiple
+1 NEW DFN1
+2 SET DFN1=0
+3 FOR
SET DFN1=$ORDER(^DPT(DFN,"DIS",DFN1))
if 'DFN1
QUIT
Begin DoDot:1
+4 if $PIECE($GET(^DPT(DFN,"DIS",DFN1,3)),U,7)&($PIECE($GET(^DPT(DFN,"DIS",DFN1,3)),U,7)']"")
SET $PIECE(^(3),U,9)=$PIECE(^(3),U,7)
End DoDot:1
+5 QUIT
MAKEZIP4(DFN) ;Populates zip+4 fields with zip code fields
+1 ;ZIP->ZIP+4
+2 DO FROMTO(DFN,.33,8,.22,1)
+3 DO FROMTO(DFN,.34,8,.22,2)
+4 DO FROMTO(DFN,.211,8,.22,3)
+5 DO FROMTO(DFN,.331,8,.22,4)
+6 DO FROMTO(DFN,.311,8,.22,5)
+7 DO FROMTO(DFN,.25,7,.22,6)
+8 DO FROMTO(DFN,.21,8,.22,7)
+9 DO FROMTO(DFN,.121,6,.121,12)
+10 DO FROMTO(DFN,.291,10,.291,12)
+11 DO FROMTO(DFN,.29,10,.29,13)
+12 DO FROMTO(DFN,.11,6,.11,12)
+13 QUIT
FROMTO(DFN,FROMNODE,FROMPC,TONODE,TOPC) ;POPULATES ZIP+4 WITH ZIP DATA
+1 ;VARIABLES:
+2 ; DFN - IEN of Patient File
+3 ;FROMNODE - zip code node
+4 ;TONODE - zip+4 node
+5 ;FROMPC - zip code piece
+6 ;TOPC -zip+4 piece
+7 ;
+8 IF '$GET(DFN)!('$GET(FROMNODE))!('$GET(FROMPC))!('$GET(TONODE))!('$GET(TOPC))
Begin DoDot:1
+9 if '$DATA(ZTQUEUED)
WRITE !,"MISSING INPUT VARIABLE"
End DoDot:1
QUIT
+10 IF $PIECE($GET(^DPT(DFN,FROMNODE)),U,FROMPC)
Begin DoDot:1
+11 if '$PIECE($GET(^DPT(DFN,TONODE)),U,TOPC)
SET $PIECE(^DPT(DFN,TONODE),U,TOPC)=$PIECE(^DPT(DFN,FROMNODE),U,FROMPC)
End DoDot:1
+12 QUIT
