AZPPTCP.m

AZPPTCP ;PAO/FCJ;COPY PATIENTS HRN TO NEW FACILITY [ 04/11/96  3:35 PM ]

 ;1/4/94

 S U="^",(DFN,CT,TST)=0

FAC S DIC(0)="AMZQE",DIC("A")="Create Patient globals for which Facility: "

 S DIC="^AUTTLOC(" D ^DIC G:Y<0 EXT 

 S FAC=$P(Y,U),FACNM=Y(0)

 W !!

FAC2 S DIC(0)="AMZQE",DIC("A")="Copy Health Record Numbers from which Facility: "

 S DIC="^AUTTLOC(" D ^DIC G:Y<0 EXT 

 S AZPFAC=$P(Y,U),AZPNM=Y(0) D CHK

 I TST=0 W !,"ERROR: THIS FACILITY DOES NOT EXIST IN THE AUPNPAT GLOBAL" G FAC

 F  S DFN=$O(^AUPNPAT(DFN)) Q:'DFN  I $D(^AUPNPAT(DFN,41,AZPFAC,0)) D  

 .S DATA=$G(^AUPNPAT(DFN,41,AZPFAC,0))

 .;I DATA="" K ^DPT(DFN),^AUPNPAT(DFN) Q

 .S CT=CT+1

 .S HRN=$P(^AUPNPAT(DFN,41,AZPFAC,0),U,2)

 .S:HRN'="" ^AUPNPAT("D",HRN,DFN,FAC)=""

 .S ^AUPNPAT(DFN,41,FAC,0)=^AUPNPAT(DFN,41,AZPFAC,0)

 .S $P(^AUPNPAT(DFN,41,FAC,0),U)=FAC

 .S $P(^AUPNPAT(DFN,41,0),U,4)=$P(^AUPNPAT(DFN,41,0),U,4)+1

 .S:FAC>AZPFAC $P(^AUPNPAT(DFN,41,0),U,3)=FAC

 G EXT1

CHK ;TEST FOR FACILITY IN WITHIN DATA

 F  S DFN=$O(^AUPNPAT(DFN)) Q:DFN'?1N.N  D  Q:TST=1

 .S DATA=$G(^AUPNPAT(DFN,41,AZPFAC,0)) I DATA'="" S TST=1

 S DFN=0 Q

EXT1 W !,"There are ",CT," patients registered for the ",$P(^DIC(4,FAC,0),U)," Facility"

EXT K DIC,X,X1,Y,AZPFAC,TST,DFN,HRN,FACNM,FAC,CT Q

AZPPTCP   ;PAO/FCJ;COPY PATIENTS HRN TO NEW FACILITY [ 04/11/96  3:35 PM ]

 +1       ;1/4/94

 +2        SET U="^"

           SET (DFN,CT,TST)=0

FAC        SET DIC(0)="AMZQE"

           SET DIC("A")="Create Patient globals for which Facility: "

 +1        SET DIC="^AUTTLOC("

           DO ^DIC

           IF Y<0

               GOTO EXT

 +2        SET FAC=$PIECE(Y,U)

           SET FACNM=Y(0)

 +3        WRITE !!

FAC2       SET DIC(0)="AMZQE"

           SET DIC("A")="Copy Health Record Numbers from which Facility: "

 +1        SET DIC="^AUTTLOC("

           DO ^DIC

           IF Y<0

               GOTO EXT

 +2        SET AZPFAC=$PIECE(Y,U)

           SET AZPNM=Y(0)

           DO CHK

 +3        IF TST=0

               WRITE !,"ERROR: THIS FACILITY DOES NOT EXIST IN THE AUPNPAT GLOBAL"

               GOTO FAC

 +4        FOR 

               SET DFN=$ORDER(^AUPNPAT(DFN))

               IF 'DFN

                   QUIT 

               IF $DATA(^AUPNPAT(DFN,41,AZPFAC,0))

                   Begin DoDot:1

 +5                    SET DATA=$GET(^AUPNPAT(DFN,41,AZPFAC,0))

 +6       ;I DATA="" K ^DPT(DFN),^AUPNPAT(DFN) Q

 +7                    SET CT=CT+1

 +8                    SET HRN=$PIECE(^AUPNPAT(DFN,41,AZPFAC,0),U,2)

 +9                    IF HRN'=""

                           SET ^AUPNPAT("D",HRN,DFN,FAC)=""

 +10                   SET ^AUPNPAT(DFN,41,FAC,0)=^AUPNPAT(DFN,41,AZPFAC,0)

 +11                   SET $PIECE(^AUPNPAT(DFN,41,FAC,0),U)=FAC

 +12                   SET $PIECE(^AUPNPAT(DFN,41,0),U,4)=$PIECE(^AUPNPAT(DFN,41,0),U,4)+1

 +13                   IF FAC>AZPFAC

                           SET $PIECE(^AUPNPAT(DFN,41,0),U,3)=FAC

                   End DoDot:1

 +14       GOTO EXT1

CHK       ;TEST FOR FACILITY IN WITHIN DATA

 +1        FOR 

               SET DFN=$ORDER(^AUPNPAT(DFN))

               IF DFN'?1N.N

                   QUIT 

               Begin DoDot:1

 +2                SET DATA=$GET(^AUPNPAT(DFN,41,AZPFAC,0))

                   IF DATA'=""

                       SET TST=1

               End DoDot:1

               IF TST=1

                   QUIT 

 +3        SET DFN=0

           QUIT 

EXT1       WRITE !,"There are ",CT," patients registered for the ",$PIECE(^DIC(4,FAC,0),U)," Facility"

EXT        KILL DIC,X,X1,Y,AZPFAC,TST,DFN,HRN,FACNM,FAC,CT

           QUIT