- DGPTFM6 ;ALB/BOK/ADL/PLT - 601 SCREEN: PROCEDURE ENTER/EDIT ;21 JUL 88 @ 0900
- ;;5.3;Registration;**164,510,729,850,898,884,1057**;Aug 13, 1993;Build 17
- ;;Per VA Directive 6402, this routine should not be modified.
- ;
- ;;ADL;Update for CSV Project;;Mar 26, 2003
- EN ; Entry point - begin date checks
- I $G(^DGPT(PTF,70)),^(70)<2871000 W !!,"Data can't be entered into Procedure Records until 10/1/1987" H 5 G ^DGPTFM
- G @($S(X=6:"E",1:X))
- ;
- T ;add procedure record
- S DGZP=0 S:'$D(^DGPT(PTF,"P",0)) ^(0)="^45.05DA^^"
- S DIC="^DGPT("_PTF_",""P"",",DIC(0)="AEQLMZ",DA(1)=PTF D ^DIC G ^DGPTFM:Y'>0!('$D(^DGPT(PTF,"P",+Y))) S DGPROCM=+Y,DGPROCD=$P(Y,U,2) D MOB I DGPC F I=1:1:DGPC S:P(I,1)=DGPROCM DGZP=I
- G:'DGZP ^DGPTFM S DGPROC(DGZP)=DGPROCM,X="1,2"
- EDIT ;
- I X'=1,X'=2,X'="1,2",X'="1-2" G HELP
- S DGCODSYS=$$CODESYS^DGPTIC10(PTF),DIE="^DGPT(",(DA,DGPTF)=PTF,DR=$S(DGCODSYS="ICD10":"[DG601-10P]",1:"[DG601]"),DGJUMP=X
- S DIE="^DGPT(",DGJUMP=X D ^DIE,CHK601^DGPTSCAN K DR,DIE,DIC,DA,DGADD,DGJUMP D MOB
- SET D MOB:'$D(P) S:'$D(DGZP) DGZP=1 S P(DGZP,1)=$S($D(P(DGZP,1)):P(DGZP,1),1:"") I P(DGZP,1)="" K P(DGZP) G NEXP
- S (P1,P(DGZP))=$S($D(^DGPT(PTF,"P",P(DGZP,1),0)):^(0),1:"")
- WRT ;
- N EFFDATE,IMPDATE
- D EFFDATE^DGPTIC10(PTF)
- G:'$D(^DGPT(PTF,"P",P(DGZP,1),0)) ^DGPTFM S DGPROCI=^(0) W @IOF,HEAD,?68 S Z="<601-"_DGZP_">" W @DGVI,Z,@DGVO
- W !,?30,"Initial Date Of Service: ",$$EXTERNAL^DILFD(45,14,,$G(DGIDTS)) ; DG*5.3*1057
- W !! S (Y,L)=+P(DGZP),Z=1 D D^DGPTUTL,Z^DGPTFM5 W $J("Date of Proc: ",32),Y,!,$J("Specialty: ",35)
- W $S($D(^DIC(42.4,+$P(P(DGZP),U,2),0)):$P(^(0),U),1:""),! I $P(P(DGZP),U,4) W " Number of Dialysis Treatments: ",$P(P(DGZP),U,4),!
- W !! S Z=2 D Z^DGPTFM5 W " Procedures: ",$$GETLABEL^DGPTIC10(EFFDATE,"P")
- ;F I=1:1:5 S L=$P(P(DGZP),U,4+I) I L D
- D PTFICD^DGPTFUT(601,PTF,P(DGZP,1),.DGX601)
- S I=0 F S I=$O(DGX601(I)) QUIT:'I S L=+DGX601(I) D
- . S DGPTTMP=$$ICDDATA^ICDXCODE("PROC",+L,EFFDATE)
- . D WRITECOD^DGPTIC10("PROC",+L,EFFDATE,2,1,7) W $S(+DGPTTMP<1!('$P(DGPTTMP,U,10)):"*",1:"") ;W !?7
- . I $Y>(IOSL-4) D PGBR W @IOF,HEAD,?72 S Z="<601-"_DGZP_">" D Z^DGPTFM W !
- . QUIT
- K DGX601
- F I=1:1:(IOSL-$Y-5) W !
- S DGNUM=$S($D(P(DGZP+1)):601_"-"_(DGZP+1),1:"MAS") G 601^DGPTFJC:DGST
- W "Enter <RET> to continue, 1-2 to edit,",!,"'T' to add a Procedure Segment, '^N' for screen N, or '^' to abort: <",DGNUM,">//"
- R X:DTIME S:'$T X="^",DGPTOUT=""
- K DGNUM G Q^DGPTF:X="^"
- I X?1"^".E S DGPTSCRN=601 G ^DGPTFJ
- G T:X="T"!(X="t"),HELP:X["?"
- I X[1!(X[2) S DA=+P(DGZP) G EDIT
- I X'="" G HELP
- NEXP ;S DGZP=DGZP+1 G ^DGPTFM:'$D(P(DGZP)),SET
- S DGZP=DGZP+1 I '$D(P(DGZP)) S DGZP=1 G ^DGPTFM
- G SET
- ;
- HELP W !,"Enter '^' to stop display and edit of data",!,"'^N' to jump to screen #N (appears in upper right of screen as <N>)",!,"<RET> to continue on to next screen or 1-2 to edit:"
- W !?10,"1-Procedure information",!,?10,"2-Procedure codes",!,"You may also enter any combination of the above, separated by commas (ex:1,2)",!
- R !!,"Enter <RET>: ",X:DTIME G WRT
- MOB K P,P1,P2 S (I,P2)=0 F I1=1:1 S I=$O(^DGPT(PTF,"P",I)) Q:I'>0 S P(I1)=^(I,0),P(I1,1)=I I P(I1)']"" K P(I1) S I1=I1-1
- S DGPC=I1-1 Q
- BS ;CALLED FROM [DG601]
- S I=$O(^DGPT(PTF,"M","AM",^DGPT(PTF,"P",DA,0)-.0000001)),I=$O(^(+I,0))
- S DGMOVM=$S($D(^DGPT(PTF,"M",$S(I:I,1:1),0)):$P(^(0),U,2),1:"")
- Q
- R ;DELETE PROCEDURE RECORD
- G R^DGPTFM4
- E ;EDIT PROCEDURE RECORD
- G E^DGPTFM1
- ;
- ;add procedure codes in 601p (before 2871000) or procedure record
- P I $G(^DGPT(PTF,70)),^(70)<2871000 G FY86
- I '$D(P2) W !,"View Prodedure Codes first",! H 3 G ^DGPTFM
- I 'P2 W !,"No codes can be added to a Procedure Record",! H 3 G ^DGPTFM
- S L=""
- S DGCODSYS=$$CODESYS^DGPTIC10(PTF),L="" F I=1:1:DGPC S L2=1 D
- . N A
- . F J=5:1:9 I $P(P(I),U,J)="" S L=L_I_",",L2=0 QUIT
- . QUIT:DGCODSYS="ICD9"!'L2
- . F J=10:1:24 I $P(P(I),U,J)="" S L=L_I_",",L2=0 QUIT:'L2
- . QUIT:'L2
- . S A=$G(^DGPT(PTF,"P",+P(I,1),1)) F J=1:1:5 I $P(A,U,J)="" S L=L_I_",",L2=0 QUIT:'L2
- . QUIT
- I L="" W !!,"There are no procedure records that can be added to.",*7 H 3 G ^DGPTFM
- S L=$E(L,1,$L(L)-1) I L=+L S DGRC=+L G P2
- P1 I 'Z W !!,"Add to procedure record <",L,"> : " R DGRC:DTIME G ^DGPTFM:DGRC[U!(DGRC="")
- E S DGRC=+$E(A,2,99)
- P2 I +DGRC'=DGRC!(","_L_","'[(","_DGRC_",")) W !!,"Enter the procedure record number to add ICD operation codes to: ",L G P1:'Z S Z="" G P1
- S DGCODSYS=$$CODESYS^DGPTIC10(PTF),DIE="^DGPT(",(DGPTF,DA)=PTF,DR=$S(DGCODSYS="ICD10":"[DG601-10P]",1:"[DG601]")
- S ST=1,DGZS0=DGRC,DGADD=1,DGZP=P(DGZS0,1) D ^DIE,CHK601^DGPTSCAN K DR,DGPTF,DGZP,DGADD G ^DGPTFM
- ;
- FY86 S DR="" F J=1:1:5 I $P(PROC,U,J)="" S DR=DR_(J/100+45)_";"
- I DR="" W !!,"No more 401P procedures (before 10/01/1987) can be added.",*7 H 3 G ^DGPTFM
- S DR=$E(DR,1,$L(DR)-1),DP=45,DIE="^DGPT(",DA=PTF D ^DIE K DR,DIE G ^DGPTFM
- GETVAR ;CALLED FROM GET+1^DGPTFM
- S PM=I1-1,I=0 F I1=1:1 S I=$O(^DGPT(PTF,"S",I)) Q:I'>0 S S(I1)=^(I,0),S(I1,1)=I
- K P2P S SU=I1-1 S PROC=$S($D(^DGPT(PTF,"401P")):^("401P"),1:""),P2P=0 F J1=1:1:5 S:$P(PROC,U,J1) P2P=P2P+1,P2P(P2P)=J1
- QUIT
- ;
- BADDT(DGPROCD) ; Check patients admit date and entered date against census DATE
- ; If admit date is after census date then we're done
- ; checks to see if Patient has been discharged or has a closed census and returns false
- ; If not discharged or closed and the admit and procedure date is within census date range then return false
- ; If admit date and procedure date is past the date range then return true
- N DGADM,DGI,DGIDS ; DG*5.3*1057
- S DGADM=$P(^DGPT(DA(1),0),U,2) ; DG*5.3*1057
- S DGIDS=$P(^DGPT(DA(1),0),U,14) ; initial date of service DG*5.3*1057
- I DGIDS>0,$G(DGPROCD,0)<DGIDS D EN^DDIOL("Must be on or after initial date of service") Q 1 ; DG*5.3*1057
- I DGIDS'>0,($G(DGPROCD,0)<$$FMADD^XLFDT(DGADM,,-72)) D EN^DDIOL("Must be at most 72 hrs prior to admission") Q 1 ; DG*5.3*1057
- I $G(DGPROCD,0)>($S($D(^DGPT(DA(1),70)):$S(+^(70):+^(70),1:9999999),1:9999999)) D EN^DDIOL("Not After discharge") Q 1
- I (DGADM>DGPTDAT) Q 0 ; Admit date is after census date
- I ($G(DGADM,$P(^DGPT(PTF,0),U,2))>DGPTDAT) Q 0 ; Admit date is after census date
- N DG601DT
- F DGI=0:0 S DGI=$O(^DGPT("ACENSUS",PTF,DGI)) Q:'DGI I $D(^DGPT(DGI,0)),$P(^(0),U,12)=PTF,$D(^DG(45.86,+$P(^(0),U,13),0)) S Y=+^(0) X ^DD("DD") S DGI(DGI)=Y
- Q:($D(DGI)>1) 0 ;Closed Census
- I $D(^DGPT(PTF,70)),$P($G(^(70)),U)'="" Q 0 ; Patient has been discharged
- S DG601DT=$S($G(DGPROCD):DGPROCD,1:$G(EFFDATE))
- Q:(DGADM<(DGPTDAT+.09))&(DG601DT<(DGPTDAT+.09)) 0 ;Admit and procedure Date in Census Range
- D EN^DDIOL("Not After Census Date") Q 1 ; Reject date
- ;
- ;
- PGBR N DIR,X,Y S DIR(0)="E",DIR("A")="Enter RETURN to continue" D ^DIR QUIT
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPTFM6 6741 printed Jan 18, 2025@03:53:05 Page 2
- DGPTFM6 ;ALB/BOK/ADL/PLT - 601 SCREEN: PROCEDURE ENTER/EDIT ;21 JUL 88 @ 0900
- +1 ;;5.3;Registration;**164,510,729,850,898,884,1057**;Aug 13, 1993;Build 17
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;
- +4 ;;ADL;Update for CSV Project;;Mar 26, 2003
- EN ; Entry point - begin date checks
- +1 IF $GET(^DGPT(PTF,70))
- IF ^(70)<2871000
- WRITE !!,"Data can't be entered into Procedure Records until 10/1/1987"
- HANG 5
- GOTO ^DGPTFM
- +2 GOTO @($SELECT(X=6:"E",1:X))
- +3 ;
- T ;add procedure record
- +1 SET DGZP=0
- if '$DATA(^DGPT(PTF,"P",0))
- SET ^(0)="^45.05DA^^"
- +2 SET DIC="^DGPT("_PTF_",""P"","
- SET DIC(0)="AEQLMZ"
- SET DA(1)=PTF
- DO ^DIC
- if Y'>0!('$DATA(^DGPT(PTF,"P",+Y)))
- GOTO ^DGPTFM
- SET DGPROCM=+Y
- SET DGPROCD=$PIECE(Y,U,2)
- DO MOB
- IF DGPC
- FOR I=1:1:DGPC
- if P(I,1)=DGPROCM
- SET DGZP=I
- +3 if 'DGZP
- GOTO ^DGPTFM
- SET DGPROC(DGZP)=DGPROCM
- SET X="1,2"
- EDIT ;
- +1 IF X'=1
- IF X'=2
- IF X'="1,2"
- IF X'="1-2"
- GOTO HELP
- +2 SET DGCODSYS=$$CODESYS^DGPTIC10(PTF)
- SET DIE="^DGPT("
- SET (DA,DGPTF)=PTF
- SET DR=$SELECT(DGCODSYS="ICD10":"[DG601-10P]",1:"[DG601]")
- SET DGJUMP=X
- +3 SET DIE="^DGPT("
- SET DGJUMP=X
- DO ^DIE
- DO CHK601^DGPTSCAN
- KILL DR,DIE,DIC,DA,DGADD,DGJUMP
- DO MOB
- SET if '$DATA(P)
- DO MOB
- if '$DATA(DGZP)
- SET DGZP=1
- SET P(DGZP,1)=$SELECT($DATA(P(DGZP,1)):P(DGZP,1),1:"")
- IF P(DGZP,1)=""
- KILL P(DGZP)
- GOTO NEXP
- +1 SET (P1,P(DGZP))=$SELECT($DATA(^DGPT(PTF,"P",P(DGZP,1),0)):^(0),1:"")
- WRT ;
- +1 NEW EFFDATE,IMPDATE
- +2 DO EFFDATE^DGPTIC10(PTF)
- +3 if '$DATA(^DGPT(PTF,"P",P(DGZP,1),0))
- GOTO ^DGPTFM
- SET DGPROCI=^(0)
- WRITE @IOF,HEAD,?68
- SET Z="<601-"_DGZP_">"
- WRITE @DGVI,Z,@DGVO
- +4 ; DG*5.3*1057
- WRITE !,?30,"Initial Date Of Service: ",$$EXTERNAL^DILFD(45,14,,$GET(DGIDTS))
- +5 WRITE !!
- SET (Y,L)=+P(DGZP)
- SET Z=1
- DO D^DGPTUTL
- DO Z^DGPTFM5
- WRITE $JUSTIFY("Date of Proc: ",32),Y,!,$JUSTIFY("Specialty: ",35)
- +6 WRITE $SELECT($DATA(^DIC(42.4,+$PIECE(P(DGZP),U,2),0)):$PIECE(^(0),U),1:""),!
- IF $PIECE(P(DGZP),U,4)
- WRITE " Number of Dialysis Treatments: ",$PIECE(P(DGZP),U,4),!
- +7 WRITE !!
- SET Z=2
- DO Z^DGPTFM5
- WRITE " Procedures: ",$$GETLABEL^DGPTIC10(EFFDATE,"P")
- +8 ;F I=1:1:5 S L=$P(P(DGZP),U,4+I) I L D
- +9 DO PTFICD^DGPTFUT(601,PTF,P(DGZP,1),.DGX601)
- +10 SET I=0
- FOR
- SET I=$ORDER(DGX601(I))
- if 'I
- QUIT
- SET L=+DGX601(I)
- Begin DoDot:1
- +11 SET DGPTTMP=$$ICDDATA^ICDXCODE("PROC",+L,EFFDATE)
- +12 ;W !?7
- DO WRITECOD^DGPTIC10("PROC",+L,EFFDATE,2,1,7)
- WRITE $SELECT(+DGPTTMP<1!('$PIECE(DGPTTMP,U,10)):"*",1:"")
- +13 IF $Y>(IOSL-4)
- DO PGBR
- WRITE @IOF,HEAD,?72
- SET Z="<601-"_DGZP_">"
- DO Z^DGPTFM
- WRITE !
- +14 QUIT
- End DoDot:1
- +15 KILL DGX601
- +16 FOR I=1:1:(IOSL-$Y-5)
- WRITE !
- +17 SET DGNUM=$SELECT($DATA(P(DGZP+1)):601_"-"_(DGZP+1),1:"MAS")
- if DGST
- GOTO 601^DGPTFJC
- +18 WRITE "Enter <RET> to continue, 1-2 to edit,",!,"'T' to add a Procedure Segment, '^N' for screen N, or '^' to abort: <",DGNUM,">//"
- +19 READ X:DTIME
- if '$TEST
- SET X="^"
- SET DGPTOUT=""
- +20 KILL DGNUM
- if X="^"
- GOTO Q^DGPTF
- +21 IF X?1"^".E
- SET DGPTSCRN=601
- GOTO ^DGPTFJ
- +22 if X="T"!(X="t")
- GOTO T
- if X["?"
- GOTO HELP
- +23 IF X[1!(X[2)
- SET DA=+P(DGZP)
- GOTO EDIT
- +24 IF X'=""
- GOTO HELP
- NEXP ;S DGZP=DGZP+1 G ^DGPTFM:'$D(P(DGZP)),SET
- +1 SET DGZP=DGZP+1
- IF '$DATA(P(DGZP))
- SET DGZP=1
- GOTO ^DGPTFM
- +2 GOTO SET
- +3 ;
- HELP WRITE !,"Enter '^' to stop display and edit of data",!,"'^N' to jump to screen #N (appears in upper right of screen as <N>)",!,"<RET> to continue on to next screen or 1-2 to edit:"
- +1 WRITE !?10,"1-Procedure information",!,?10,"2-Procedure codes",!,"You may also enter any combination of the above, separated by commas (ex:1,2)",!
- +2 READ !!,"Enter <RET>: ",X:DTIME
- GOTO WRT
- MOB KILL P,P1,P2
- SET (I,P2)=0
- FOR I1=1:1
- SET I=$ORDER(^DGPT(PTF,"P",I))
- if I'>0
- QUIT
- SET P(I1)=^(I,0)
- SET P(I1,1)=I
- IF P(I1)']""
- KILL P(I1)
- SET I1=I1-1
- +1 SET DGPC=I1-1
- QUIT
- BS ;CALLED FROM [DG601]
- +1 SET I=$ORDER(^DGPT(PTF,"M","AM",^DGPT(PTF,"P",DA,0)-.0000001))
- SET I=$ORDER(^(+I,0))
- +2 SET DGMOVM=$SELECT($DATA(^DGPT(PTF,"M",$SELECT(I:I,1:1),0)):$PIECE(^(0),U,2),1:"")
- +3 QUIT
- R ;DELETE PROCEDURE RECORD
- +1 GOTO R^DGPTFM4
- E ;EDIT PROCEDURE RECORD
- +1 GOTO E^DGPTFM1
- +2 ;
- +3 ;add procedure codes in 601p (before 2871000) or procedure record
- P IF $GET(^DGPT(PTF,70))
- IF ^(70)<2871000
- GOTO FY86
- +1 IF '$DATA(P2)
- WRITE !,"View Prodedure Codes first",!
- HANG 3
- GOTO ^DGPTFM
- +2 IF 'P2
- WRITE !,"No codes can be added to a Procedure Record",!
- HANG 3
- GOTO ^DGPTFM
- +3 SET L=""
- +4 SET DGCODSYS=$$CODESYS^DGPTIC10(PTF)
- SET L=""
- FOR I=1:1:DGPC
- SET L2=1
- Begin DoDot:1
- +5 NEW A
- +6 FOR J=5:1:9
- IF $PIECE(P(I),U,J)=""
- SET L=L_I_","
- SET L2=0
- QUIT
- +7 if DGCODSYS="ICD9"!'L2
- QUIT
- +8 FOR J=10:1:24
- IF $PIECE(P(I),U,J)=""
- SET L=L_I_","
- SET L2=0
- if 'L2
- QUIT
- +9 if 'L2
- QUIT
- +10 SET A=$GET(^DGPT(PTF,"P",+P(I,1),1))
- FOR J=1:1:5
- IF $PIECE(A,U,J)=""
- SET L=L_I_","
- SET L2=0
- if 'L2
- QUIT
- +11 QUIT
- End DoDot:1
- +12 IF L=""
- WRITE !!,"There are no procedure records that can be added to.",*7
- HANG 3
- GOTO ^DGPTFM
- +13 SET L=$EXTRACT(L,1,$LENGTH(L)-1)
- IF L=+L
- SET DGRC=+L
- GOTO P2
- P1 IF 'Z
- WRITE !!,"Add to procedure record <",L,"> : "
- READ DGRC:DTIME
- if DGRC[U!(DGRC="")
- GOTO ^DGPTFM
- +1 IF '$TEST
- SET DGRC=+$EXTRACT(A,2,99)
- P2 IF +DGRC'=DGRC!(","_L_","'[(","_DGRC_","))
- WRITE !!,"Enter the procedure record number to add ICD operation codes to: ",L
- if 'Z
- GOTO P1
- SET Z=""
- GOTO P1
- +1 SET DGCODSYS=$$CODESYS^DGPTIC10(PTF)
- SET DIE="^DGPT("
- SET (DGPTF,DA)=PTF
- SET DR=$SELECT(DGCODSYS="ICD10":"[DG601-10P]",1:"[DG601]")
- +2 SET ST=1
- SET DGZS0=DGRC
- SET DGADD=1
- SET DGZP=P(DGZS0,1)
- DO ^DIE
- DO CHK601^DGPTSCAN
- KILL DR,DGPTF,DGZP,DGADD
- GOTO ^DGPTFM
- +3 ;
- FY86 SET DR=""
- FOR J=1:1:5
- IF $PIECE(PROC,U,J)=""
- SET DR=DR_(J/100+45)_";"
- +1 IF DR=""
- WRITE !!,"No more 401P procedures (before 10/01/1987) can be added.",*7
- HANG 3
- GOTO ^DGPTFM
- +2 SET DR=$EXTRACT(DR,1,$LENGTH(DR)-1)
- SET DP=45
- SET DIE="^DGPT("
- SET DA=PTF
- DO ^DIE
- KILL DR,DIE
- GOTO ^DGPTFM
- GETVAR ;CALLED FROM GET+1^DGPTFM
- +1 SET PM=I1-1
- SET I=0
- FOR I1=1:1
- SET I=$ORDER(^DGPT(PTF,"S",I))
- if I'>0
- QUIT
- SET S(I1)=^(I,0)
- SET S(I1,1)=I
- +2 KILL P2P
- SET SU=I1-1
- SET PROC=$SELECT($DATA(^DGPT(PTF,"401P")):^("401P"),1:"")
- SET P2P=0
- FOR J1=1:1:5
- if $PIECE(PROC,U,J1)
- SET P2P=P2P+1
- SET P2P(P2P)=J1
- +3 QUIT
- +4 ;
- BADDT(DGPROCD) ; Check patients admit date and entered date against census DATE
- +1 ; If admit date is after census date then we're done
- +2 ; checks to see if Patient has been discharged or has a closed census and returns false
- +3 ; If not discharged or closed and the admit and procedure date is within census date range then return false
- +4 ; If admit date and procedure date is past the date range then return true
- +5 ; DG*5.3*1057
- NEW DGADM,DGI,DGIDS
- +6 ; DG*5.3*1057
- SET DGADM=$PIECE(^DGPT(DA(1),0),U,2)
- +7 ; initial date of service DG*5.3*1057
- SET DGIDS=$PIECE(^DGPT(DA(1),0),U,14)
- +8 ; DG*5.3*1057
- IF DGIDS>0
- IF $GET(DGPROCD,0)<DGIDS
- DO EN^DDIOL("Must be on or after initial date of service")
- QUIT 1
- +9 ; DG*5.3*1057
- IF DGIDS'>0
- IF ($GET(DGPROCD,0)<$$FMADD^XLFDT(DGADM,,-72))
- DO EN^DDIOL("Must be at most 72 hrs prior to admission")
- QUIT 1
- +10 IF $GET(DGPROCD,0)>($SELECT($DATA(^DGPT(DA(1),70)):$SELECT(+^(70):+^(70),1:9999999),1:9999999))
- DO EN^DDIOL("Not After discharge")
- QUIT 1
- +11 ; Admit date is after census date
- IF (DGADM>DGPTDAT)
- QUIT 0
- +12 ; Admit date is after census date
- IF ($GET(DGADM,$PIECE(^DGPT(PTF,0),U,2))>DGPTDAT)
- QUIT 0
- +13 NEW DG601DT
- +14 FOR DGI=0:0
- SET DGI=$ORDER(^DGPT("ACENSUS",PTF,DGI))
- if 'DGI
- QUIT
- IF $DATA(^DGPT(DGI,0))
- IF $PIECE(^(0),U,12)=PTF
- IF $DATA(^DG(45.86,+$PIECE(^(0),U,13),0))
- SET Y=+^(0)
- XECUTE ^DD("DD")
- SET DGI(DGI)=Y
- +15 ;Closed Census
- if ($DATA(DGI)>1)
- QUIT 0
- +16 ; Patient has been discharged
- IF $DATA(^DGPT(PTF,70))
- IF $PIECE($GET(^(70)),U)'=""
- QUIT 0
- +17 SET DG601DT=$SELECT($GET(DGPROCD):DGPROCD,1:$GET(EFFDATE))
- +18 ;Admit and procedure Date in Census Range
- if (DGADM<(DGPTDAT+.09))&(DG601DT<(DGPTDAT+.09))
- QUIT 0
- +19 ; Reject date
- DO EN^DDIOL("Not After Census Date")
- QUIT 1
- +20 ;
- +21 ;
- PGBR NEW DIR,X,Y
- SET DIR(0)="E"
- SET DIR("A")="Enter RETURN to continue"
- DO ^DIR
- QUIT
- +1 ;