DGPTR3.m

DGPTR3 ;ALB/JDS/MJK - ALB/BOK  PTF TRANSMISSION ; 01 DEC 87 @0800

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

 ;

535 ; -- setup 535 transactions

 F I=0:0 S I=$O(^DGPT(J,535,I)) Q:'I  I $D(^(I,0)) S DGM=^(0),DGTD=+$P(DGM,U,10) I $P(DGM,U,17)'="n",'$P(DGM,U,7),'$D(^DGPT(J,"M","AM",DGTD)),DGTD'<T1,DGTD'>T2 D PHY

 Q

 ;

PHY ; -- set up physcial mvt

 S Y=$S(T1:"C",1:"N")_"535"_DGHEAD,X=$P(DGTD,".")_"       ",Y=Y_$E(X,4,5)_$E(X,6,7)_$E(X,2,3)_$E($P(DGTD,".",2)_"0000",1,4)

 ; physical cdr

 S Z=$P(DGM,U,16) D CDR^DGPTR2

 ; physical specialty

 ;replace specialty pointer (ien) with ptf code (alpha-numeric)

 N DGARRX,DGARRY ;DG729

 S DGARRX=$$TSDATA^DGACT(42.4,$P(DGM,U,2),.DGARRY)

 S $P(DGM,U,2)=$G(DGARRY(7))

 S L=2,X=DGM,Z=2 D ENTER0

 ; find corresponding PTF mvt

 S X="",Z=+$O(^DGPT(J,"M","AM",DGTD-.0000001)),Z=$S(Z:+$O(^(Z,0)),1:1) I $D(^DGPT(J,"M",Z,0)) S X=^(0) ; use d/c mvt if 'Z

 ; specialty cdr

 S Z=$P(X,U,16) D CDR^DGPTR2

 ; specialty

 ;replace specialty pointer (ien) with ptf code (alpha-numeric)

 N DGARRX,DGARRY ;DG729

 S DGARRX=$$TSDATA^DGACT(42.4,$P(X,U,2),.DGARRY)

 S $P(X,U,2)=$G(DGARRY(7))

 S L=2,Z=2 D ENTER0

 ; 

 ; convert pass, leave days >999 to 999

 S X=DGM,L=3 F Z=3,4 S:$P(X,U,Z)>999 $P(X,U,Z)=999 D ENTER0

 D FILL^DGPTR2,SAVE

 K DGM,X,Z,L Q

 ;

ENTER S Y=Y_$J($P(X,U,Z),L)

 Q

 ;

ENTER0 S Y=Y_$S($P(X,U,Z)]"":$E("00000",$L($P(X,U,Z))+1,L)_$P(X,U,Z),1:$J($P(X,U,Z),L))

 Q

 ;

SAVE D START^DGPTR1 S:'DGERR ^XMB(3.9,DGXMZ,2,DGCNT,0)=Y,DGCNT=DGCNT+1

 I DGERR'>0 S DGACNT=DGACNT+1,^TMP("AEDIT",$J,$E(Y,1,4),DGACNT)=Y

Q Q

DGPTR3    ;ALB/JDS/MJK - ALB/BOK  PTF TRANSMISSION ; 01 DEC 87 @0800

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

 +2       ;

535       ; -- setup 535 transactions

 +1        FOR I=0:0

               SET I=$ORDER(^DGPT(J,535,I))

               IF 'I

                   QUIT 

               IF $DATA(^(I,0))

                   SET DGM=^(0)

                   SET DGTD=+$PIECE(DGM,U,10)

                   IF $PIECE(DGM,U,17)'="n"

                       IF '$PIECE(DGM,U,7)

                           IF '$DATA(^DGPT(J,"M","AM",DGTD))

                               IF DGTD'<T1

                                   IF DGTD'>T2

                                       DO PHY

 +2        QUIT 

 +3       ;

PHY       ; -- set up physcial mvt

 +1        SET Y=$SELECT(T1:"C",1:"N")_"535"_DGHEAD

           SET X=$PIECE(DGTD,".")_"       "

           SET Y=Y_$EXTRACT(X,4,5)_$EXTRACT(X,6,7)_$EXTRACT(X,2,3)_$EXTRACT($PIECE(DGTD,".",2)_"0000",1,4)

 +2       ; physical cdr

 +3        SET Z=$PIECE(DGM,U,16)

           DO CDR^DGPTR2

 +4       ; physical specialty

 +5       ;replace specialty pointer (ien) with ptf code (alpha-numeric)

 +6       ;DG729

           NEW DGARRX,DGARRY

 +7        SET DGARRX=$$TSDATA^DGACT(42.4,$PIECE(DGM,U,2),.DGARRY)

 +8        SET $PIECE(DGM,U,2)=$GET(DGARRY(7))

 +9        SET L=2

           SET X=DGM

           SET Z=2

           DO ENTER0

 +10      ; find corresponding PTF mvt

 +11      ; use d/c mvt if 'Z

           SET X=""

           SET Z=+$ORDER(^DGPT(J,"M","AM",DGTD-.0000001))

           SET Z=$SELECT(Z:+$ORDER(^(Z,0)),1:1)

           IF $DATA(^DGPT(J,"M",Z,0))

               SET X=^(0)

 +12      ; specialty cdr

 +13       SET Z=$PIECE(X,U,16)

           DO CDR^DGPTR2

 +14      ; specialty

 +15      ;replace specialty pointer (ien) with ptf code (alpha-numeric)

 +16      ;DG729

           NEW DGARRX,DGARRY

 +17       SET DGARRX=$$TSDATA^DGACT(42.4,$PIECE(X,U,2),.DGARRY)

 +18       SET $PIECE(X,U,2)=$GET(DGARRY(7))

 +19       SET L=2

           SET Z=2

           DO ENTER0

 +20      ; 

 +21      ; convert pass, leave days >999 to 999

 +22       SET X=DGM

           SET L=3

           FOR Z=3,4

               IF $PIECE(X,U,Z)>999

                   SET $PIECE(X,U,Z)=999

               DO ENTER0

 +23       DO FILL^DGPTR2

           DO SAVE

 +24       KILL DGM,X,Z,L

           QUIT 

 +25      ;

ENTER      SET Y=Y_$JUSTIFY($PIECE(X,U,Z),L)

 +1        QUIT 

 +2       ;

ENTER0     SET Y=Y_$SELECT($PIECE(X,U,Z)]"":$EXTRACT("00000",$LENGTH($PIECE(X,U,Z))+1,L)_$PIECE(X,U,Z),1:$JUSTIFY($PIECE(X,U,Z),L))

 +1        QUIT 

 +2       ;

SAVE       DO START^DGPTR1

           IF 'DGERR

               SET ^XMB(3.9,DGXMZ,2,DGCNT,0)=Y

               SET DGCNT=DGCNT+1

 +1        IF DGERR'>0

               SET DGACNT=DGACNT+1

               SET ^TMP("AEDIT",$JOB,$EXTRACT(Y,1,4),DGACNT)=Y

Q          QUIT