DGYPREG5.m

DGYPREG5 ;ALB/REW - ZIP+4 POST-INIT CONVERSION ;4-JUN-93

 ;;5.3;Registration;**1015**;Aug 13, 1993;Build 21

 ;

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

DGYPREG5  ;ALB/REW - ZIP+4 POST-INIT CONVERSION ;4-JUN-93

 +1       ;;5.3;Registration;**1015**;Aug 13, 1993;Build 21

 +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