- DGPTR2 ;ALB/JDS/MJK/MTC/ADL/TJ/BOK,HIOFO/FT - PTF TRANSMISSION ;4/20/15 9:59am
- ;;5.3;Registration;**183,338,423,510,636,729,850,884**;Aug 13, 1993;Build 31
- ;;ADL;Update for CSV Project;;Mar 27,2003
- ;
- ; ^XMB(3.9) - #10113
- ; ICDXCODE APIs - #5699
- ;
- 501 ; -- setup 501 transactions
- ; DG*636
- N DGPTMVDT
- I $D(^DGPT(J,70))
- K DGCMVT I T2'=9999999 S DGCMVT=$O(^DGPT(J,"M","AM",+$P(T2,".")_".2359")),DGCMVT=$S('DGCMVT:1,$O(^(DGCMVT,0)):$O(^(0)),1:1)
- F I=0:0 S I=$O(^DGPT(J,"M",I)) G 535:I'>0 I $D(^(I,0)) D
- . S DGM=^(0),DGSC=$P(DGM,U,18),DGAO=$P(DGM,U,26),DGIR=$P(DGM,U,27),DGEC=$P(DGM,U,28),DGMST=$P(DGM,U,29),DGHNC=$P(DGM,U,30),DGTD=$P(DGM,U,10),DGPTMVDT=$P(DGM,U,10)
- . S:$D(DGCMVT) DGTD=$S(I=DGCMVT:$P(T2,".")_".2359",1:DGTD)
- . I $P(DGM,U,17)'="n",DGTD,DGTD'<T1,DGTD'>T2 D MOV
- MOV S DGCDR=$P(DGM,U,16),DGM=$P(DGM,U,1,9)_U_$P(DGM,U,11,15),L=1 F Z=5:1:14 S:'$P(DGM,U,Z) DGM=$P(DGM,U,1,Z-1)_U_$P(DGM,U,Z+1,99) S:'$P(DGM,U,Z) Z=Z-1 S L=L+1 Q:L=10
- S Y=$S(T1:"C",1:"N")_"501"_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)
- S Z=DGCDR D CDR
- ;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
- ; convert pass, leave days >999 to 999
- S L=3 F Z=3,4 S:$P(X,U,Z)>999 $P(X,U,Z)=999 D ENTER0
- S L=1,X=DG57,Z=4 D ENTER S:I=1 DG502=Y
- N EFFDATE,IMPDATE,DGPTDAT D EFFDATE^DGPTIC10(J)
- F Z=5:1:9 S DGPTTMP=$$ICDDATA^ICDXCODE("DIAG",+$P(DGM,U,Z),EFFDATE,"I") D
- . S F=$S(+DGPTTMP>0&($P(DGPTTMP,U,10)):$P(DGPTTMP,U,2),1:" ."),F=$P(F,".",1)_$E($P(F,".",2)_" ",1,3),F=F_$E(" ",1,7-$L(F)),Y=Y_F
- K DGPTEDT
- S Y=Y_" "
- S X=""
- I 'T1 S Z=$S(I=1:+$O(^DGPT(J,535,"ADC",0)),1:+$O(^DGPT(J,535,"AM",DGTD-.0000001))) I $D(^DGPT(J,535,+$O(^(Z,0)),0)) S X=^(0)
- I T1 S Z=+$O(^DGPT(J,535,"AM",DGTD-.0000001)) S:'Z Z=+$O(^DGPT(J,535,"ADC",0)) I $D(^DGPT(J,535,+$O(^(Z,0)),0)) S X=^(0)
- S Z=$P(X,U,16) D CDR
- ;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
- ; bed occupant
- I T1 S Y=Y_$S(I=1:$E($P(DG70,U,14)_" "),$P(+DGTD,".")=$P(T2,"."):5,1:1)
- I 'T1 S Y=Y_$S(I=1:$E($P(DG70,U,14)_" "),1:" ")
- ;-- additional ptf questions
- S DGAUX=$S($D(^DGPT(J,"M",I,300)):^(300),1:"")
- D ADDQUES
- ;-- sc related care
- S Y=Y_$E(DGSC_" ")
- ;-- ao related care
- S Y=Y_$E(DGAO_" ")
- ;-- ir related care
- S Y=Y_$E(DGIR_" ")
- ;-- ec related care
- S Y=Y_$E(DGEC_" ")
- ;-- mst related care
- S Y=Y_$E(DGMST_" ")
- ;-- Head/Neck CA related care
- S Y=Y_$E(DGHNC_" ")
- K DGAUX,DGDRUG,DGSC,DGAO,DGIR,DGEC,DGMST,DGHNC
- D FILL,SAVE
- Q
- 535 ; -- do 535's
- D 535^DGPTR3
- ;
- PROC ; -- setup 601 transactions
- K ^UTILITY($J,"PROC") S I=0
- 601 S I=$O(^DGPT(J,"P",I)) G 701:I'>0 S (X,DGPROC)=^(I,0) G 601:'DGPROC
- G 601:DGPROC<T1!(DGPROC>T2) S DGPROCD=+^DGPT(J,"P",I,0),^UTILITY($J,"PROC",DGPROCD)=$S($D(^UTILITY($J,"PROC",DGPROCD)):^(DGPROCD),1:0)+1
- I ^UTILITY($J,"PROC",DGPROCD)>1 W !,"More than one procedure record on same date/time" S DGERR=1 Q
- S Y=$S('T1:"N",1:"C")_"601"_DGHEAD_$E(DGPROCD,4,7)_$E(DGPROCD,2,3)_$E($P(+X,".",2)_"0000",1,4)
- ;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
- S L=1,Z=3 S $P(X,U,Z)="" D ENTER ;null dialysis type. DG729
- S L=3,Z=4 D ENTER0
- N EFFDATE,IMPDATE,DGPTDAT D EFFDATE^DGPTIC10(J)
- S L=1 F K=5:1:9 S:'$P(DGPROC,U,K) DGPROC=$P(DGPROC,U,1,K-1)_U_$P(DGPROC,U,K+1,99),K=K-1 S L=L+1 Q:L=5
- F K=5:1:9 S DGPTTMP=$$ICDDATA^ICDXCODE("PROC",+$P(DGPROC,U,K),EFFDATE,"I") D
- . S Y=Y_$S(+DGPTTMP>0&($P(DGPTTMP,U,10)):$J($P($P(DGPTTMP,U,2),".",1),2)_$E($P($P(DGPTTMP,U,2),".",2)_" ",1,3),1:" ")_" "
- K DGPTEDT
- D FILL,SAVE G 601
- Q
- ;
- 701 ; -- setup 701 transaction
- D 701^DGPTR4 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 ;save segment to MailMan message and ^TMP("AEDIT",$J), if data is valid
- N DGY1,DGY2
- S (DGY1,DGY2)=""
- D START^DGPTR1 ;validate data in segment
- I DGERR'>0 S DGACNT=DGACNT+1,^TMP("AEDIT",$J,$E(Y,1,4),DGACNT)=Y ;^TMP("AEDIT",$J) used by DGPTAE* for more data validation
- ;AITC wants segment length of 384 characters.
- ;Break the segment at 240.
- I 'DGERR D
- .D FILL384
- .I $E(Y,2,4)=101 S DGY1=$E(Y,1,240),DGY2=$E(Y,241,384)
- .I $E(Y,2,4)=401 S DGY1=$E(Y,1,240),DGY2=$E(Y,241,384)
- .I $E(Y,2,4)=501 S DGY1=$E(Y,1,240),DGY2=$E(Y,241,384)
- .I $E(Y,2,4)=535 S DGY1=$E(Y,1,240),DGY2=$E(Y,241,384)
- .I $E(Y,2,4)=601 S DGY1=$E(Y,1,240),DGY2=$E(Y,241,384)
- .I $E(Y,2,4)=701 S DGY1=$E(Y,1,240),DGY2=$E(Y,241,384)
- .I $E(Y,2,4)=702 S DGY1=$E(Y,1,240),DGY2=$E(Y,241,384)
- .Q:DGY1=""!(DGY2="")
- .S ^XMB(3.9,DGXMZ,2,DGCNT,0)=DGY1,DGCNT=DGCNT+1
- .S ^XMB(3.9,DGXMZ,2,DGCNT,0)=DGY2,DGCNT=DGCNT+1
- Q Q
- ;
- FILL ;pad with spaces to 125 characters (so DGPTR1 data checks work)
- F K=$L(Y):1:124 S Y=Y_" "
- Q
- FILL384 ;pad out with spaces to 384 characters for AITC transmission
- F K=$L(Y):1:383 S Y=Y_" "
- S $E(Y,383)="9" ;383rd character=9 to indicate ICD9 record. DGPTRI2 sets 383rd character=1 to indicate ICD10 record.
- Q
- ;
- CDR S Y=Y_$E($P(Z,".")_"0000",1,4)_$E($P(Z,".",2)_"00",1,2)
- Q
- ADDQUES ;-- additional PTF questions load records for trans 501/701
- N DGADDQ
- F DGADDQ=2,3,4 D ;null results if discharge>inactive date. DG/729
- . I +$P($G(^DIC(45.88,DGADDQ,0)),U,3) S $P(DGAUX,U,DGADDQ)=$S((+$G(^DGPT(J,70))<$P(^DIC(45.88,DGADDQ,0),U,3)):$P(DGAUX,U,DGADDQ),1:"")
- S DGDRUG=$S($D(^DIC(45.61,+$P(DGAUX,U,4),0)):$P(^(0),U,2),1:" ")
- S Y=Y_$E($P(DGAUX,U,3)_" ")_$E($P(DGAUX,U,2)_" ")_$J($P(DGDRUG,U),4)
- S Y=Y_$E($P(DGAUX,U,5)_" ")
- S DGT=0,X=$P(DGAUX,U,6) I X]"" S DGT=1,Z=1,L=2 D ENTER0
- I 'DGT S Y=Y_" "
- S DGT=0,X=$P(DGAUX,U,7) I X]"" S DGT=1,Z=1,L=2 D ENTER0
- I 'DGT S Y=Y_" "
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPTR2 6086 printed Feb 19, 2025@00:19:25 Page 2
- DGPTR2 ;ALB/JDS/MJK/MTC/ADL/TJ/BOK,HIOFO/FT - PTF TRANSMISSION ;4/20/15 9:59am
- +1 ;;5.3;Registration;**183,338,423,510,636,729,850,884**;Aug 13, 1993;Build 31
- +2 ;;ADL;Update for CSV Project;;Mar 27,2003
- +3 ;
- +4 ; ^XMB(3.9) - #10113
- +5 ; ICDXCODE APIs - #5699
- +6 ;
- 501 ; -- setup 501 transactions
- +1 ; DG*636
- +2 NEW DGPTMVDT
- +3 IF $DATA(^DGPT(J,70))
- +4 KILL DGCMVT
- IF T2'=9999999
- SET DGCMVT=$ORDER(^DGPT(J,"M","AM",+$PIECE(T2,".")_".2359"))
- SET DGCMVT=$SELECT('DGCMVT:1,$ORDER(^(DGCMVT,0)):$ORDER(^(0)),1:1)
- +5 FOR I=0:0
- SET I=$ORDER(^DGPT(J,"M",I))
- if I'>0
- GOTO 535
- IF $DATA(^(I,0))
- Begin DoDot:1
- +6 SET DGM=^(0)
- SET DGSC=$PIECE(DGM,U,18)
- SET DGAO=$PIECE(DGM,U,26)
- SET DGIR=$PIECE(DGM,U,27)
- SET DGEC=$PIECE(DGM,U,28)
- SET DGMST=$PIECE(DGM,U,29)
- SET DGHNC=$PIECE(DGM,U,30)
- SET DGTD=$PIECE(DGM,U,10)
- SET DGPTMVDT=$PIECE(DGM,U,10)
- +7 if $DATA(DGCMVT)
- SET DGTD=$SELECT(I=DGCMVT:$PIECE(T2,".")_".2359",1:DGTD)
- +8 IF $PIECE(DGM,U,17)'="n"
- IF DGTD
- IF DGTD'<T1
- IF DGTD'>T2
- DO MOV
- End DoDot:1
- MOV SET DGCDR=$PIECE(DGM,U,16)
- SET DGM=$PIECE(DGM,U,1,9)_U_$PIECE(DGM,U,11,15)
- SET L=1
- FOR Z=5:1:14
- if '$PIECE(DGM,U,Z)
- SET DGM=$PIECE(DGM,U,1,Z-1)_U_$PIECE(DGM,U,Z+1,99)
- if '$PIECE(DGM,U,Z)
- SET Z=Z-1
- SET L=L+1
- if L=10
- QUIT
- +1 SET Y=$SELECT(T1:"C",1:"N")_"501"_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 SET Z=DGCDR
- DO CDR
- +3 ;replace specialty pointer (ien) with ptf code (alpha-numeric)
- +4 ;DG729
- NEW DGARRX,DGARRY
- +5 SET DGARRX=$$TSDATA^DGACT(42.4,$PIECE(DGM,U,2),.DGARRY)
- +6 SET $PIECE(DGM,U,2)=$GET(DGARRY(7))
- +7 SET L=2
- SET X=DGM
- SET Z=2
- DO ENTER0
- +8 ; convert pass, leave days >999 to 999
- +9 SET L=3
- FOR Z=3,4
- if $PIECE(X,U,Z)>999
- SET $PIECE(X,U,Z)=999
- DO ENTER0
- +10 SET L=1
- SET X=DG57
- SET Z=4
- DO ENTER
- if I=1
- SET DG502=Y
- +11 NEW EFFDATE,IMPDATE,DGPTDAT
- DO EFFDATE^DGPTIC10(J)
- +12 FOR Z=5:1:9
- SET DGPTTMP=$$ICDDATA^ICDXCODE("DIAG",+$PIECE(DGM,U,Z),EFFDATE,"I")
- Begin DoDot:1
- +13 SET F=$SELECT(+DGPTTMP>0&($PIECE(DGPTTMP,U,10)):$PIECE(DGPTTMP,U,2),1:" .")
- SET F=$PIECE(F,".",1)_$EXTRACT($PIECE(F,".",2)_" ",1,3)
- SET F=F_$EXTRACT(" ",1,7-$LENGTH(F))
- SET Y=Y_F
- End DoDot:1
- +14 KILL DGPTEDT
- +15 SET Y=Y_" "
- +16 SET X=""
- +17 IF 'T1
- SET Z=$SELECT(I=1:+$ORDER(^DGPT(J,535,"ADC",0)),1:+$ORDER(^DGPT(J,535,"AM",DGTD-.0000001)))
- IF $DATA(^DGPT(J,535,+$ORDER(^(Z,0)),0))
- SET X=^(0)
- +18 IF T1
- SET Z=+$ORDER(^DGPT(J,535,"AM",DGTD-.0000001))
- if 'Z
- SET Z=+$ORDER(^DGPT(J,535,"ADC",0))
- IF $DATA(^DGPT(J,535,+$ORDER(^(Z,0)),0))
- SET X=^(0)
- +19 SET Z=$PIECE(X,U,16)
- DO CDR
- +20 ;replace specialty pointer (ien) with ptf code (alpha-numeric)
- +21 ;DG729
- NEW DGARRX,DGARRY
- +22 SET DGARRX=$$TSDATA^DGACT(42.4,$PIECE(X,U,2),.DGARRY)
- +23 SET $PIECE(X,U,2)=$GET(DGARRY(7))
- +24 SET L=2
- SET Z=2
- DO ENTER0
- +25 ; bed occupant
- +26 IF T1
- SET Y=Y_$SELECT(I=1:$EXTRACT($PIECE(DG70,U,14)_" "),$PIECE(+DGTD,".")=$PIECE(T2,"."):5,1:1)
- +27 IF 'T1
- SET Y=Y_$SELECT(I=1:$EXTRACT($PIECE(DG70,U,14)_" "),1:" ")
- +28 ;-- additional ptf questions
- +29 SET DGAUX=$SELECT($DATA(^DGPT(J,"M",I,300)):^(300),1:"")
- +30 DO ADDQUES
- +31 ;-- sc related care
- +32 SET Y=Y_$EXTRACT(DGSC_" ")
- +33 ;-- ao related care
- +34 SET Y=Y_$EXTRACT(DGAO_" ")
- +35 ;-- ir related care
- +36 SET Y=Y_$EXTRACT(DGIR_" ")
- +37 ;-- ec related care
- +38 SET Y=Y_$EXTRACT(DGEC_" ")
- +39 ;-- mst related care
- +40 SET Y=Y_$EXTRACT(DGMST_" ")
- +41 ;-- Head/Neck CA related care
- +42 SET Y=Y_$EXTRACT(DGHNC_" ")
- +43 KILL DGAUX,DGDRUG,DGSC,DGAO,DGIR,DGEC,DGMST,DGHNC
- +44 DO FILL
- DO SAVE
- +45 QUIT
- 535 ; -- do 535's
- +1 DO 535^DGPTR3
- +2 ;
- PROC ; -- setup 601 transactions
- +1 KILL ^UTILITY($JOB,"PROC")
- SET I=0
- 601 SET I=$ORDER(^DGPT(J,"P",I))
- if I'>0
- GOTO 701
- SET (X,DGPROC)=^(I,0)
- if 'DGPROC
- GOTO 601
- +1 if DGPROC<T1!(DGPROC>T2)
- GOTO 601
- SET DGPROCD=+^DGPT(J,"P",I,0)
- SET ^UTILITY($JOB,"PROC",DGPROCD)=$SELECT($DATA(^UTILITY($JOB,"PROC",DGPROCD)):^(DGPROCD),1:0)+1
- +2 IF ^UTILITY($JOB,"PROC",DGPROCD)>1
- WRITE !,"More than one procedure record on same date/time"
- SET DGERR=1
- QUIT
- +3 SET Y=$SELECT('T1:"N",1:"C")_"601"_DGHEAD_$EXTRACT(DGPROCD,4,7)_$EXTRACT(DGPROCD,2,3)_$EXTRACT($PIECE(+X,".",2)_"0000",1,4)
- +4 ;replace specialty pointer (ien) with ptf code (alpha-numeric)
- +5 ;DG729
- NEW DGARRX,DGARRY
- +6 SET DGARRX=$$TSDATA^DGACT(42.4,$PIECE(X,U,2),.DGARRY)
- +7 SET $PIECE(X,U,2)=$GET(DGARRY(7))
- +8 SET L=2
- SET Z=2
- DO ENTER0
- +9 ;null dialysis type. DG729
- SET L=1
- SET Z=3
- SET $PIECE(X,U,Z)=""
- DO ENTER
- +10 SET L=3
- SET Z=4
- DO ENTER0
- +11 NEW EFFDATE,IMPDATE,DGPTDAT
- DO EFFDATE^DGPTIC10(J)
- +12 SET L=1
- FOR K=5:1:9
- if '$PIECE(DGPROC,U,K)
- SET DGPROC=$PIECE(DGPROC,U,1,K-1)_U_$PIECE(DGPROC,U,K+1,99)
- SET K=K-1
- SET L=L+1
- if L=5
- QUIT
- +13 FOR K=5:1:9
- SET DGPTTMP=$$ICDDATA^ICDXCODE("PROC",+$PIECE(DGPROC,U,K),EFFDATE,"I")
- Begin DoDot:1
- +14 SET Y=Y_$SELECT(+DGPTTMP>0&($PIECE(DGPTTMP,U,10)):$JUSTIFY($PIECE($PIECE(DGPTTMP,U,2),".",1),2)_$EXTRACT($PIECE($PIECE(DGPTTMP,U,2),".",2)_" ",1,3),1:" ")_" "
- End DoDot:1
- +15 KILL DGPTEDT
- +16 DO FILL
- DO SAVE
- GOTO 601
- +17 QUIT
- +18 ;
- 701 ; -- setup 701 transaction
- +1 DO 701^DGPTR4
- QUIT
- +2 ;
- 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 ;save segment to MailMan message and ^TMP("AEDIT",$J), if data is valid
- +1 NEW DGY1,DGY2
- +2 SET (DGY1,DGY2)=""
- +3 ;validate data in segment
- DO START^DGPTR1
- +4 ;^TMP("AEDIT",$J) used by DGPTAE* for more data validation
- IF DGERR'>0
- SET DGACNT=DGACNT+1
- SET ^TMP("AEDIT",$JOB,$EXTRACT(Y,1,4),DGACNT)=Y
- +5 ;AITC wants segment length of 384 characters.
- +6 ;Break the segment at 240.
- +7 IF 'DGERR
- Begin DoDot:1
- +8 DO FILL384
- +9 IF $EXTRACT(Y,2,4)=101
- SET DGY1=$EXTRACT(Y,1,240)
- SET DGY2=$EXTRACT(Y,241,384)
- +10 IF $EXTRACT(Y,2,4)=401
- SET DGY1=$EXTRACT(Y,1,240)
- SET DGY2=$EXTRACT(Y,241,384)
- +11 IF $EXTRACT(Y,2,4)=501
- SET DGY1=$EXTRACT(Y,1,240)
- SET DGY2=$EXTRACT(Y,241,384)
- +12 IF $EXTRACT(Y,2,4)=535
- SET DGY1=$EXTRACT(Y,1,240)
- SET DGY2=$EXTRACT(Y,241,384)
- +13 IF $EXTRACT(Y,2,4)=601
- SET DGY1=$EXTRACT(Y,1,240)
- SET DGY2=$EXTRACT(Y,241,384)
- +14 IF $EXTRACT(Y,2,4)=701
- SET DGY1=$EXTRACT(Y,1,240)
- SET DGY2=$EXTRACT(Y,241,384)
- +15 IF $EXTRACT(Y,2,4)=702
- SET DGY1=$EXTRACT(Y,1,240)
- SET DGY2=$EXTRACT(Y,241,384)
- +16 if DGY1=""!(DGY2="")
- QUIT
- +17 SET ^XMB(3.9,DGXMZ,2,DGCNT,0)=DGY1
- SET DGCNT=DGCNT+1
- +18 SET ^XMB(3.9,DGXMZ,2,DGCNT,0)=DGY2
- SET DGCNT=DGCNT+1
- End DoDot:1
- Q QUIT
- +1 ;
- FILL ;pad with spaces to 125 characters (so DGPTR1 data checks work)
- +1 FOR K=$LENGTH(Y):1:124
- SET Y=Y_" "
- +2 QUIT
- FILL384 ;pad out with spaces to 384 characters for AITC transmission
- +1 FOR K=$LENGTH(Y):1:383
- SET Y=Y_" "
- +2 ;383rd character=9 to indicate ICD9 record. DGPTRI2 sets 383rd character=1 to indicate ICD10 record.
- SET $EXTRACT(Y,383)="9"
- +3 QUIT
- +4 ;
- CDR SET Y=Y_$EXTRACT($PIECE(Z,".")_"0000",1,4)_$EXTRACT($PIECE(Z,".",2)_"00",1,2)
- +1 QUIT
- ADDQUES ;-- additional PTF questions load records for trans 501/701
- +1 NEW DGADDQ
- +2 ;null results if discharge>inactive date. DG/729
- FOR DGADDQ=2,3,4
- Begin DoDot:1
- +3 IF +$PIECE($GET(^DIC(45.88,DGADDQ,0)),U,3)
- SET $PIECE(DGAUX,U,DGADDQ)=$SELECT((+$GET(^DGPT(J,70))<$PIECE(^DIC(45.88,DGADDQ,0),U,3)):$PIECE(DGAUX,U,DGADDQ),1:"")
- End DoDot:1
- +4 SET DGDRUG=$SELECT($DATA(^DIC(45.61,+$PIECE(DGAUX,U,4),0)):$PIECE(^(0),U,2),1:" ")
- +5 SET Y=Y_$EXTRACT($PIECE(DGAUX,U,3)_" ")_$EXTRACT($PIECE(DGAUX,U,2)_" ")_$JUSTIFY($PIECE(DGDRUG,U),4)
- +6 SET Y=Y_$EXTRACT($PIECE(DGAUX,U,5)_" ")
- +7 SET DGT=0
- SET X=$PIECE(DGAUX,U,6)
- IF X]""
- SET DGT=1
- SET Z=1
- SET L=2
- DO ENTER0
- +8 IF 'DGT
- SET Y=Y_" "
- +9 SET DGT=0
- SET X=$PIECE(DGAUX,U,7)
- IF X]""
- SET DGT=1
- SET Z=1
- SET L=2
- DO ENTER0
- +10 IF 'DGT
- SET Y=Y_" "
- +11 QUIT