- 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
