- 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 ;