APSPAD2.m

APSPAD2 ;IHS/DSD/ENM - BUILD AD2 X-REF [ 09/03/97   1:30 PM ]

 ;;6.0;IHS PHARMACY MODIFICATIONS;;09/03/97

 ;This routine will build the "AD2" X-Ref for all division fields

 ;which is used by several reports.

EP ;ENTRY POINT

 D NOW^%DTC S X1=X,X2=-90 D C^%DTC S APSPTIME=X

 S I=0,APSP=0,APSP1=0,APSP2=0,DA=""

 F  S I=$O(^PSRX(I)) Q:'I  D NEW,REF,PAR

 Q

NEW ;

 Q:$P($G(^PSRX(I,0)),"^",13)<APSPTIME

 Q:$G(^PSRX(I,2))=""  ;QUIT AT END 

 I $P($G(^PSRX(I,2)),"^",9)]"" S TYPE="N",DA=I D SET K DA

 Q

REF ;

 Q:$P($G(^PSRX(I,1,0)),"^",3)<1

 S APSP1=0 F  S APSP1=$O(^PSRX(I,1,APSP1)) Q:'APSP1  I $P($G(^PSRX(I,1,APSP1,0)),"^")'<APSPTIME  S TYPE="R",DA(1)=I,DA=APSP1 D SET K DA(1),DA

 Q

PAR ;

 Q:$G(^PSRX(I,"P",0))="" 

 S APSP2=0 F  S APSP2=$O(^PSRX(I,"P",APSP2)) Q:'APSP2  I $P($G(^PSRX(I,"P",APSP2,0)),"^")'<APSPTIME  S TYPE="P",DA(1)=I,DA=APSP2 D SET K DA(1),DA

 Q

SET ;

 I TYPE="N" S DIK(1)="20^AD2",DIK="^PSRX(" D EN1^DIK Q

 I TYPE="R" S DIK(1)="8^AD3",DIK="^PSRX("_DA(1)_",1," D EN1^DIK W !,I,?10,"TY= ",TYPE Q

 I TYPE="P" S DIK(1)=".09^AD4",DIK="^PSRX("_DA(1)_",""P""," D EN1^DIK W !,I,?10,"TY= ",TYPE Q

 Q

APSPAD2   ;IHS/DSD/ENM - BUILD AD2 X-REF [ 09/03/97   1:30 PM ]

 +1       ;;6.0;IHS PHARMACY MODIFICATIONS;;09/03/97

 +2       ;This routine will build the "AD2" X-Ref for all division fields

 +3       ;which is used by several reports.

EP        ;ENTRY POINT

 +1        DO NOW^%DTC

           SET X1=X

           SET X2=-90

           DO C^%DTC

           SET APSPTIME=X

 +2        SET I=0

           SET APSP=0

           SET APSP1=0

           SET APSP2=0

           SET DA=""

 +3        FOR 

               SET I=$ORDER(^PSRX(I))

               IF 'I

                   QUIT 

               DO NEW

               DO REF

               DO PAR

 +4        QUIT 

NEW       ;

 +1        IF $PIECE($GET(^PSRX(I,0)),"^",13)<APSPTIME

               QUIT 

 +2       ;QUIT AT END 

           IF $GET(^PSRX(I,2))=""

               QUIT 

 +3        IF $PIECE($GET(^PSRX(I,2)),"^",9)]""

               SET TYPE="N"

               SET DA=I

               DO SET

               KILL DA

 +4        QUIT 

REF       ;

 +1        IF $PIECE($GET(^PSRX(I,1,0)),"^",3)<1

               QUIT 

 +2        SET APSP1=0

           FOR 

               SET APSP1=$ORDER(^PSRX(I,1,APSP1))

               IF 'APSP1

                   QUIT 

               IF $PIECE($GET(^PSRX(I,1,APSP1,0)),"^")'<APSPTIME

                   SET TYPE="R"

                   SET DA(1)=I

                   SET DA=APSP1

                   DO SET

                   KILL DA(1),DA

 +3        QUIT 

PAR       ;

 +1        IF $GET(^PSRX(I,"P",0))=""

               QUIT 

 +2        SET APSP2=0

           FOR 

               SET APSP2=$ORDER(^PSRX(I,"P",APSP2))

               IF 'APSP2

                   QUIT 

               IF $PIECE($GET(^PSRX(I,"P",APSP2,0)),"^")'<APSPTIME

                   SET TYPE="P"

                   SET DA(1)=I

                   SET DA=APSP2

                   DO SET

                   KILL DA(1),DA

 +3        QUIT 

SET       ;

 +1        IF TYPE="N"

               SET DIK(1)="20^AD2"

               SET DIK="^PSRX("

               DO EN1^DIK

               QUIT 

 +2        IF TYPE="R"

               SET DIK(1)="8^AD3"

               SET DIK="^PSRX("_DA(1)_",1,"

               DO EN1^DIK

               WRITE !,I,?10,"TY= ",TYPE

               QUIT 

 +3        IF TYPE="P"

               SET DIK(1)=".09^AD4"

               SET DIK="^PSRX("_DA(1)_",""P"","

               DO EN1^DIK

               WRITE !,I,?10,"TY= ",TYPE

               QUIT 

 +4        QUIT