Routine: DGPTAPA3

DGPTAPA3 ;ALB/MTC - PTF A/P ARCHIVE UTILITY CONT. ; 10-19-92

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

AR501 ;-- this function will load the 501 information

 N X,Y,I,J,K,OSEQ,SEQ

 S OSEQ=$G(^DGP(45.62,DGTMP,100,0)) Q:OSEQ']""

 S SEQ=$P(OSEQ,U,3),REF="^DGP(45.62,"_DGTMP_",100)"

 S (K,I)=0 F  S I=$O(^DGPT(DGPTF,"M",I)) Q:'I  D

 . S K=K+1,SEQ=SEQ+1,X=$G(^DGPT(DGPTF,"M",I,0)) Q:X']""

 .;-- movement date (4)

 . S Y=DGPTF_U_"501"_U_K_U_$S($P(X,U,10):$P(X,U,10),1:"")

 .;-- treated for and SC condition (5)

 . S Y=Y_U_$S($P(X,U,18)=1:"YES",1:"NO")

 .;-- leave days (6)

 . S Y=Y_U_$S($P(X,U,3):$P(X,U,3),1:"")

 .;-- pass days (7)

 . S Y=Y_U_$S($P(X,U,4):$P(X,U,4),1:"")

 .;-- losing specilaty (8)

 . S Y=Y_U_$S($P(X,U,2):$P(^DIC(42.4,$P(X,U,2),0),U),1:"")

.;

 .;-- check for ICD codes (9-18)

 . F J=5:1:9,11:1:15 D

 .. S Y=Y_U_$S($P(X,U,J):$P(^ICD9($P(X,U,J),0),U),1:"")

.;

 .;-- check for 300 node information (19-24)

.;

 . S X2=$G(^DGPT(DGPTF,"M",I,300))

 . S Y=Y_U_$$AR300^DGPTAPA1(X2)

 . S SEQ=SEQ+1,@REF@(SEQ,0)=Y

 ;-- update

 S $P(^DGP(45.62,DGTMP,100,0),U,3,4)=SEQ_U_SEQ

AR535 ;-- this function will load the 535 information

 N Y,X,I,DG535,OSEQ,SEQ

 S OSEQ=$G(^DGP(45.62,DGTMP,100,0)) Q:OSEQ']""

 S SEQ=$P(OSEQ,U,3),REF="^DGP(45.62,"_DGTMP_",100)"

 S (I,DG535)=0 F  S DG535=$O(^DGPT(DGPTF,535,DG535)) Q:'DG535  D

 . S I=I+1,SEQ=SEQ+1,X=$G(^DGPT(DGPTF,535,DG535,0)),X1=""

 .;-- physical movement # (4)

 . S Y=DGPTF_U_"535"_U_I_U_$S($P(X,U,10):$P(X,U,10),1:"")

 .;-- losing specialty (5)

 . S Y=Y_U_$P(^DIC(42.4,$P(X,U,2),0),U,1)

 .;-- leave days (6)

 . S Y=Y_U_$P(X,U,3)

 .;-- pass days (7)

 . S Y=Y_U_$P(X,U,4)

 .; losing ward (8)

 . S Y=Y_U_$P(^DIC(42,$P(X,U,6),0),U)

 . S @REF@(SEQ,0)=Y

 ;-- update

 S $P(^DGP(45.62,DGTMP,100,0),U,3,4)=SEQ_U_SEQ

DGPTAPA3  ;ALB/MTC - PTF A/P ARCHIVE UTILITY CONT. ; 10-19-92

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

 +2       ;

AR501     ;-- this function will load the 501 information

 +1        NEW X,Y,I,J,K,OSEQ,SEQ

 +2        SET OSEQ=$GET(^DGP(45.62,DGTMP,100,0))

           IF OSEQ']""

               QUIT

 +3        SET SEQ=$PIECE(OSEQ,U,3)

           SET REF="^DGP(45.62,"_DGTMP_",100)"

 +4       ;

 +5        SET (K,I)=0

FOR

               SET I=$ORDER(^DGPT(DGPTF,"M",I))

               IF 'I

                   QUIT

               Begin DoDot:1

 +6                SET K=K+1

                   SET SEQ=SEQ+1

                   SET X=$GET(^DGPT(DGPTF,"M",I,0))

                   IF X']""

                       QUIT

 +7       ;-- movement date (4)

 +8                SET Y=DGPTF_U_"501"_U_K_U_$SELECT($PIECE(X,U,10):$PIECE(X,U,10),1:"")

 +9       ;-- treated for and SC condition (5)

 +10               SET Y=Y_U_$SELECT($PIECE(X,U,18)=1:"YES",1:"NO")

 +11      ;-- leave days (6)

 +12               SET Y=Y_U_$SELECT($PIECE(X,U,3):$PIECE(X,U,3),1:"")

 +13      ;-- pass days (7)

 +14               SET Y=Y_U_$SELECT($PIECE(X,U,4):$PIECE(X,U,4),1:"")

 +15      ;-- losing specilaty (8)

 +16               SET Y=Y_U_$SELECT($PIECE(X,U,2):$PIECE(^DIC(42.4,$PIECE(X,U,2),0),U),1:"")

 +17      ;

 +18      ;-- check for ICD codes (9-18)

 +19               FOR J=5:1:9,11:1:15

                       Begin DoDot:2

 +20                       SET Y=Y_U_$SELECT($PIECE(X,U,J):$PIECE(^ICD9($PIECE(X,U,J),0),U),1:"")

                       End DoDot:2

 +21      ;

 +22      ;-- check for 300 node information (19-24)

 +23      ;

 +24               SET X2=$GET(^DGPT(DGPTF,"M",I,300))

 +25               SET Y=Y_U_$$AR300^DGPTAPA1(X2)

 +26               SET SEQ=SEQ+1

                   SET @REF@(SEQ,0)=Y

               End DoDot:1

 +27      ;-- update

 +28       SET $PIECE(^DGP(45.62,DGTMP,100,0),U,3,4)=SEQ_U_SEQ

 +29       QUIT

 +30      ;

AR535     ;-- this function will load the 535 information

 +1        NEW Y,X,I,DG535,OSEQ,SEQ

 +2        SET OSEQ=$GET(^DGP(45.62,DGTMP,100,0))

           IF OSEQ']""

               QUIT

 +3        SET SEQ=$PIECE(OSEQ,U,3)

           SET REF="^DGP(45.62,"_DGTMP_",100)"

 +4       ;

 +5        SET (I,DG535)=0

FOR

               SET DG535=$ORDER(^DGPT(DGPTF,535,DG535))

               IF 'DG535

                   QUIT

               Begin DoDot:1

 +6                SET I=I+1

                   SET SEQ=SEQ+1

                   SET X=$GET(^DGPT(DGPTF,535,DG535,0))

                   SET X1=""

 +7       ;-- physical movement # (4)

 +8                SET Y=DGPTF_U_"535"_U_I_U_$SELECT($PIECE(X,U,10):$PIECE(X,U,10),1:"")

 +9       ;-- losing specialty (5)

 +10               SET Y=Y_U_$PIECE(^DIC(42.4,$PIECE(X,U,2),0),U,1)

 +11      ;-- leave days (6)

 +12               SET Y=Y_U_$PIECE(X,U,3)

 +13      ;-- pass days (7)

 +14               SET Y=Y_U_$PIECE(X,U,4)

 +15      ; losing ward (8)

 +16               SET Y=Y_U_$PIECE(^DIC(42,$PIECE(X,U,6),0),U)

 +17               SET @REF@(SEQ,0)=Y

               End DoDot:1

 +18      ;-- update

 +19       SET $PIECE(^DGP(45.62,DGTMP,100,0),U,3,4)=SEQ_U_SEQ

 +20       QUIT

 +21      ;

DGPTAPA3.m