DGPTAPA3 ;ALB/MTC - PTF A/P ARCHIVE UTILITY CONT. ; 10-19-92
;;5.3;Registration;;Aug 13, 1993
;
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
Q
;
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
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPTAPA3 1823 printed Sep 23, 2025@20:27:32 Page 2
DGPTAPA3 ;ALB/MTC - PTF A/P ARCHIVE UTILITY CONT. ; 10-19-92
+1 ;;5.3;Registration;;Aug 13, 1993
+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 ;
