DGPTAPA2.m

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

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

 ;

AR401 ;-- this function will load the 401 information

 N X,X1,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,"S",I)) Q:'I  D

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

 .;-- surgery date (4)

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

 .;-- sur specialty (5)

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

 .;-- cat of chief sur (6)

 . S Y=Y_U_$S($P(X,U,4):$P($P($P(^DD(45.01,4,0),U,3),";",$P(X,U,4)),":",2),$P(X,U,4)="V":"VA TEAM",$P(X,U,4)="M":"MIXED VA&NON VA",$P(X,U,4)="N":"NON VA",1:"")

 .;-- cat of first ass (7), pric ana (8), source of pay (9)

 . F J=5,6,7 S Y=Y_U_$S($P(X,U,J):$P($P($P(^DD(45.01,J,0),U,3),";",$P(X,U,J)),":",2),1:"")

 .;

 .;-- check for ICD codes (10-14)

 . F J=8:1:12 D

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

 .;

 .;-- check for 300 node information (15)

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

 . S Y=Y_U_$S($P(X2,U,2)=1:"Live Donor",$P(X2,U,2)=2:"Cadaver",1:"")

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

 .;

 .;-- 401P 

 .;-- ICD codes (4-9)

 . S X3=$G(^DGPT(DGPTF,"401P")) I X3]"" D  S @REF@(SEQ,0)=Y

 .. S SEQ=SEQ+1,Y=DGPTF_U_"401P"_U_K F J=1:1:5 I $P(X3,U,J) D

 ... S Y=Y_U_$P(^ICD0($P(X3,U,J),0),U)

 .;

 ;

 ;-- update

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

 Q

 ;

AR601 ;-- this function will load the 601 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,"P",I)) Q:'I  D

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

 .;-- procedure date (4)

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

 .;-- specialty (5)

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

 .;-- dialysis type (6)

 . S Y=Y_U_$P($G(^DG(45.4,+$P(X,U,3),0)),U)

 .;-- # of treat (7)

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

 .;-- ICD codes (8-12)

 . F J=5:1:9 D

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

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

 ;

 ;-- update

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

 Q

 ;

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

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

 +2       ;

AR401     ;-- this function will load the 401 information

 +1        NEW X,X1,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,"S",I))

               IF 'I

                   QUIT 

               Begin DoDot:1

 +6                SET K=K+1

                   SET SEQ=SEQ+1

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

                   IF X']""

                       QUIT 

 +7       ;-- surgery date (4)

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

 +9       ;-- sur specialty (5)

 +10               SET Y=Y_U_$SELECT($PIECE(X,U,3):$PIECE($GET(^DIC(45.3,$PIECE(X,U,3),0)),U,2),1:"")

 +11      ;-- cat of chief sur (6)

 +12               SET Y=Y_U_$SELECT($PIECE(X,U,4):$PIECE($PIECE($PIECE(^DD(45.01,4,0),U,3),";",$PIECE(X,U,4)),":",2),$PIECE(X,U,4)="V":"VA TEAM",$PIECE(X,U,4)="M":"MIXED VA&NON VA",$PIECE(X,U,4)="N":"NON VA",1:"")

 +13      ;-- cat of first ass (7), pric ana (8), source of pay (9)

 +14               FOR J=5,6,7

                       SET Y=Y_U_$SELECT($PIECE(X,U,J):$PIECE($PIECE($PIECE(^DD(45.01,J,0),U,3),";",$PIECE(X,U,J)),":",2),1:"")

 +15      ;

 +16      ;-- check for ICD codes (10-14)

 +17               FOR J=8:1:12

                       Begin DoDot:2

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

                       End DoDot:2

 +19      ;

 +20      ;-- check for 300 node information (15)

 +21               SET X2=$GET(^DGPT(DGPTF,"S",I,300))

 +22               SET Y=Y_U_$SELECT($PIECE(X2,U,2)=1:"Live Donor",$PIECE(X2,U,2)=2:"Cadaver",1:"")

 +23               SET SEQ=SEQ+1

                   SET @REF@(SEQ,0)=Y

 +24      ;

 +25      ;-- 401P 

 +26      ;-- ICD codes (4-9)

 +27               SET X3=$GET(^DGPT(DGPTF,"401P"))

                   IF X3]""

                       Begin DoDot:2

 +28                       SET SEQ=SEQ+1

                           SET Y=DGPTF_U_"401P"_U_K

                           FOR J=1:1:5

                               IF $PIECE(X3,U,J)

                                   Begin DoDot:3

 +29                                   SET Y=Y_U_$PIECE(^ICD0($PIECE(X3,U,J),0),U)

                                   End DoDot:3

                       End DoDot:2

                       SET @REF@(SEQ,0)=Y

 +30      ;

               End DoDot:1

 +31      ;

 +32      ;-- update

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

 +34       QUIT 

 +35      ;

AR601     ;-- this function will load the 601 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,"P",I))

               IF 'I

                   QUIT 

               Begin DoDot:1

 +6                SET K=K+1

                   SET SEQ=SEQ+1

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

                   IF X']""

                       QUIT 

 +7       ;-- procedure date (4)

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

 +9       ;-- specialty (5)

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

 +11      ;-- dialysis type (6)

 +12               SET Y=Y_U_$PIECE($GET(^DG(45.4,+$PIECE(X,U,3),0)),U)

 +13      ;-- # of treat (7)

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

 +15      ;-- ICD codes (8-12)

 +16               FOR J=5:1:9

                       Begin DoDot:2

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

                       End DoDot:2

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

               End DoDot:1

 +19      ;

 +20      ;-- update

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

 +22       QUIT 

 +23      ;