DGPTFM3 ;ALB/ADL - MASTER CPT RECORD ENTER/EDIT PART 2 ;5/5/05 7:35am
;;5.3;Registration;**517,590,594,635,696,850**;Aug 13, 1993;Build 171
REQ ;CHECK FOR REQUIRED FIELDS IN CPT RECORDS. RECORDS MISSING ONE OR MORE REQUIRED FIELDS ARE DELETED.
S RFL=0 G REQQ:'$D(DGZPRF(DGZP,0))
I '$P(^DGPT(PTF,"C",DGZPRF(DGZP,0),0),U,3) S DA(1)=PTF,DA=DGPSM,DIK="^DGPT("_PTF_",""C""," D G REQQ
.D ^DIK K DA W !!,"No CPT record has been filed because no performing provider was specified." S RFL=1
S (I,FCPT)=0 D RESEQ(PTF)
F J=1:1 S I=$O(^DGCPT(46,"C",PTF,I)) Q:'I D:+^DGCPT(46,I,1)=+DGZPRF(DGZP)&'$G(^(9))
.I $P(^DGCPT(46,I,0),U,4) S FCPT=1 Q
.S DA=I,DIK="^DGCPT(46,",CPT=+^DGCPT(46,I,0) D ^DIK
.W !!,"CPT " S N=$$CPT^ICPTCOD(CPT,$$GETDATE^ICDGTDRG(PTF)) W $P(N,U,2)," ",$P(N,U,3)," not filed because no diagnosis 1 was entered."
.S RFL=1
I FCPT K FCPT,I,J,N G REQQ
S DA(1)=PTF,DA=DGZPRF(DGZP,0),DIK="^DGPT("_PTF_",""C"","
D ^DIK K DA W !!,"No CPT record has been filed because no CPT codes were filed." S RFL=1 K FCPT,I,J,N
REQQ ;D RESEQ(PTF)
Q ;REQ
RESEQ(PTF) ;A subroutine to check if a DGN in the DGCPT global has been deleted and the other DGN's need
;to be moved down in sequence to fill the "gap" in the global
N REC,CPTINFO,DGNARAY
S REC=0
F S REC=$O(^DGCPT(46,"C",PTF,REC)) Q:REC="" K DGNARAY S CPTINFO=^DGCPT(46,REC,0) D
. F J=4:1:7,15:1:18 S DGNARAY(J)=$P(CPTINFO,U,J)
. I $$CHKGAP(.DGNARAY) D RESEQDGN(.CPTINFO,.DGNARAY) S ^DGCPT(46,REC,0)=CPTINFO
Q ;RESEQ
CHKGAP(DGNARAY) ;Function call to determine if an inside DGN code has been deleted
;Back up in the DGNARAY array until a non-null DGN ien is found, then continuing backwards,
;if a null ien is located, that means that an "inside" DGN was deleted
S SEQ=999,END=1,MISSING=0
F S SEQ=$O(DGNARAY(SEQ),-1) Q:SEQ=""!MISSING D
. I DGNARAY(SEQ)'="" S END=1 Q
. I DGNARAY(SEQ)="",END=1 S MISSING=1
Q MISSING
;
RESEQDGN(CPTINFO,DGNARAY) ;Subroutine to shift down DGN codes to replace any inside DGN's that were deleted by the user
;
N I
S SEQ="" K NOTNULL
F S SEQ=$O(DGNARAY(SEQ)) Q:SEQ="" I DGNARAY(SEQ)'="" S NOTNULL(SEQ)=DGNARAY(SEQ)
K DGNARAY S SEQ=""
F I=4:1:7,15:1:18 S DGNARAY(I)=""
F I=4:1:7,15:1:18 S SEQ=$O(NOTNULL(SEQ)) Q:SEQ="" S DGNARAY(I)=NOTNULL(SEQ)
F I=4:1:7,15:1:18 S $P(CPTINFO,U,I)=$G(DGNARAY(I))
K NOTNULL
Q ;RESEQDGN
PF S PTF=D0,DFN=+^DGPT(D0,0) D MOB^DGPTFM2 S PS2=0,J=+DGZPRF
G END:'$P(DGZPRF,U,3)
LOOP S Y=+DGZPRF(J),DGSTRT=$S(+$P(DGZPRF,U,4):$P(DGZPRF,U,4),1:4),DGLST=0
D CL^SDCO21(DFN,+DGZPRF(J),"",.SDCLY),ICDINFO^DGAPI(DFN,PTF),XREF^DGPTFM21 ; load SCI info and DGN's for this service date
D D^DGPTUTL W !,J,"-CPT Capture Date/Time: ",Y W:($P(DGZPRF,U,2)-1!($G(PGBRK))) " (cont.)"
I $P(DGZPRF(J),U,2) W !,?5,"Referring or Ordering Provider: " S L=$P(DGZPRF(J),U,2) D PRV^DGPTFM
W !,?5,"Rendering Provider: " S L=$P(DGZPRF(J),U,3) D PRV^DGPTFM
I $P(DGZPRF(J),U,5) W !,?5,"Rendering Location: ",$P($G(^SC($P(DGZPRF(J),U,5),0)),U)
S (L1,PGBRK)=0
N EFFDATE,IMPDATE
D EFFDATE^DGPTIC10(PTF)
N ICDLABEL S ICDLABEL=$$GETLABEL^DGPTIC10(DGPTDAT,"P")
F K1=$P(DGZPRF,U,2):1 Q:'$D(DGZPRF(J,K1)) I '$G(DGZPRF(J,K1,9)) D Q:$Y+$G(DGZPRF(J,K1+1,1))>16!($G(PGBRK))
. S PS2=PS2+1,K=K1 W !,?2,PS2," " D CPT^DGPTUTL1
. W !,?4 S $P(DS,"-",21)="" W DS," Related Diagnosis",ICDLABEL," ",DS
. F L1=DGSTRT:1:11 S DGLOC=$S(L1<8:L1,1:L1+7),CD=$P(DGZPRF(J,K1),U,DGLOC) I CD D I $Y+$G(CKSCI)>16 S PGBRK=1 Q
. . S N=$$ICDDATA^ICDXCODE("DIAG",CD,EFFDATE) ;,N=$S(N:$P(N,U,2,99),1:"")
. . S CD=$P(N,U) D WRITECOD^DGPTIC10("DIAG",CD,EFFDATE,1,1,8) W $S(+N<1!('$P(N,U,10)):"*",1:"")
. . D CKSCI^DGPTFM($P(DGZPRF(J,K1),U,DGLOC))
. S PS2(PS2)=J_U_K1,CD=1,DGLOC=0,DGSTRT=4
I L1'=11,$S(L1<8:$P($G(DGZPRF(J,K1)),U,L1+1,7),1:"")_$P($G(DGZPRF(J,K1)),U,$S(L1<8:15,1:L1+8),18)?."^" S L1=11
I L1=11 S $P(DGZPRF,U,1,2)=$S($D(DGZPRF(J,K1+1)):J_U_(K1+1),1:J+1_U_1),$P(DGZPRF,U,4)="",PGBRK=0
E S $P(DGZPRF,U,1,2)=J_U_K1,$P(DGZPRF,U,4)=L1+1
S J=+DGZPRF I $D(DGZPRF(J)) D HEAD^DGPTFMO G LOOP
END I $E(IOST)="C" W ! S DIR(0)="E" D ^DIR K DIR
K I,K1,L1,CD,N Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDGPTFM3 4142 printed Apr 09, 2024@21:45:53 Page 2
DGPTFM3 ;ALB/ADL - MASTER CPT RECORD ENTER/EDIT PART 2 ;5/5/05 7:35am
+1 ;;5.3;Registration;**517,590,594,635,696,850**;Aug 13, 1993;Build 171
REQ ;CHECK FOR REQUIRED FIELDS IN CPT RECORDS. RECORDS MISSING ONE OR MORE REQUIRED FIELDS ARE DELETED.
+1 SET RFL=0
if '$DATA(DGZPRF(DGZP,0))
GOTO REQQ
+2 IF '$PIECE(^DGPT(PTF,"C",DGZPRF(DGZP,0),0),U,3)
SET DA(1)=PTF
SET DA=DGPSM
SET DIK="^DGPT("_PTF_",""C"","
Begin DoDot:1
+3 DO ^DIK
KILL DA
WRITE !!,"No CPT record has been filed because no performing provider was specified."
SET RFL=1
End DoDot:1
GOTO REQQ
+4 SET (I,FCPT)=0
DO RESEQ(PTF)
+5 FOR J=1:1
SET I=$ORDER(^DGCPT(46,"C",PTF,I))
if 'I
QUIT
if +^DGCPT(46,I,1)=+DGZPRF(DGZP)&'$GET(^(9))
Begin DoDot:1
+6 IF $PIECE(^DGCPT(46,I,0),U,4)
SET FCPT=1
QUIT
+7 SET DA=I
SET DIK="^DGCPT(46,"
SET CPT=+^DGCPT(46,I,0)
DO ^DIK
+8 WRITE !!,"CPT "
SET N=$$CPT^ICPTCOD(CPT,$$GETDATE^ICDGTDRG(PTF))
WRITE $PIECE(N,U,2)," ",$PIECE(N,U,3)," not filed because no diagnosis 1 was entered."
+9 SET RFL=1
End DoDot:1
+10 IF FCPT
KILL FCPT,I,J,N
GOTO REQQ
+11 SET DA(1)=PTF
SET DA=DGZPRF(DGZP,0)
SET DIK="^DGPT("_PTF_",""C"","
+12 DO ^DIK
KILL DA
WRITE !!,"No CPT record has been filed because no CPT codes were filed."
SET RFL=1
KILL FCPT,I,J,N
REQQ ;D RESEQ(PTF)
+1 ;REQ
QUIT
RESEQ(PTF) ;A subroutine to check if a DGN in the DGCPT global has been deleted and the other DGN's need
+1 ;to be moved down in sequence to fill the "gap" in the global
+2 NEW REC,CPTINFO,DGNARAY
+3 SET REC=0
+4 FOR
SET REC=$ORDER(^DGCPT(46,"C",PTF,REC))
if REC=""
QUIT
KILL DGNARAY
SET CPTINFO=^DGCPT(46,REC,0)
Begin DoDot:1
+5 FOR J=4:1:7,15:1:18
SET DGNARAY(J)=$PIECE(CPTINFO,U,J)
+6 IF $$CHKGAP(.DGNARAY)
DO RESEQDGN(.CPTINFO,.DGNARAY)
SET ^DGCPT(46,REC,0)=CPTINFO
End DoDot:1
+7 ;RESEQ
QUIT
CHKGAP(DGNARAY) ;Function call to determine if an inside DGN code has been deleted
+1 ;Back up in the DGNARAY array until a non-null DGN ien is found, then continuing backwards,
+2 ;if a null ien is located, that means that an "inside" DGN was deleted
+3 SET SEQ=999
SET END=1
SET MISSING=0
+4 FOR
SET SEQ=$ORDER(DGNARAY(SEQ),-1)
if SEQ=""!MISSING
QUIT
Begin DoDot:1
+5 IF DGNARAY(SEQ)'=""
SET END=1
QUIT
+6 IF DGNARAY(SEQ)=""
IF END=1
SET MISSING=1
End DoDot:1
+7 QUIT MISSING
+8 ;
RESEQDGN(CPTINFO,DGNARAY) ;Subroutine to shift down DGN codes to replace any inside DGN's that were deleted by the user
+1 ;
+2 NEW I
+3 SET SEQ=""
KILL NOTNULL
+4 FOR
SET SEQ=$ORDER(DGNARAY(SEQ))
if SEQ=""
QUIT
IF DGNARAY(SEQ)'=""
SET NOTNULL(SEQ)=DGNARAY(SEQ)
+5 KILL DGNARAY
SET SEQ=""
+6 FOR I=4:1:7,15:1:18
SET DGNARAY(I)=""
+7 FOR I=4:1:7,15:1:18
SET SEQ=$ORDER(NOTNULL(SEQ))
if SEQ=""
QUIT
SET DGNARAY(I)=NOTNULL(SEQ)
+8 FOR I=4:1:7,15:1:18
SET $PIECE(CPTINFO,U,I)=$GET(DGNARAY(I))
+9 KILL NOTNULL
+10 ;RESEQDGN
QUIT
PF SET PTF=D0
SET DFN=+^DGPT(D0,0)
DO MOB^DGPTFM2
SET PS2=0
SET J=+DGZPRF
+1 if '$PIECE(DGZPRF,U,3)
GOTO END
LOOP SET Y=+DGZPRF(J)
SET DGSTRT=$SELECT(+$PIECE(DGZPRF,U,4):$PIECE(DGZPRF,U,4),1:4)
SET DGLST=0
+1 ; load SCI info and DGN's for this service date
DO CL^SDCO21(DFN,+DGZPRF(J),"",.SDCLY)
DO ICDINFO^DGAPI(DFN,PTF)
DO XREF^DGPTFM21
+2 DO D^DGPTUTL
WRITE !,J,"-CPT Capture Date/Time: ",Y
if ($PIECE(DGZPRF,U,2)-1!($GET(PGBRK)))
WRITE " (cont.)"
+3 IF $PIECE(DGZPRF(J),U,2)
WRITE !,?5,"Referring or Ordering Provider: "
SET L=$PIECE(DGZPRF(J),U,2)
DO PRV^DGPTFM
+4 WRITE !,?5,"Rendering Provider: "
SET L=$PIECE(DGZPRF(J),U,3)
DO PRV^DGPTFM
+5 IF $PIECE(DGZPRF(J),U,5)
WRITE !,?5,"Rendering Location: ",$PIECE($GET(^SC($PIECE(DGZPRF(J),U,5),0)),U)
+6 SET (L1,PGBRK)=0
+7 NEW EFFDATE,IMPDATE
+8 DO EFFDATE^DGPTIC10(PTF)
+9 NEW ICDLABEL
SET ICDLABEL=$$GETLABEL^DGPTIC10(DGPTDAT,"P")
+10 FOR K1=$PIECE(DGZPRF,U,2):1
if '$DATA(DGZPRF(J,K1))
QUIT
IF '$GET(DGZPRF(J,K1,9))
Begin DoDot:1
+11 SET PS2=PS2+1
SET K=K1
WRITE !,?2,PS2," "
DO CPT^DGPTUTL1
+12 WRITE !,?4
SET $PIECE(DS,"-",21)=""
WRITE DS," Related Diagnosis",ICDLABEL," ",DS
+13 FOR L1=DGSTRT:1:11
SET DGLOC=$SELECT(L1<8:L1,1:L1+7)
SET CD=$PIECE(DGZPRF(J,K1),U,DGLOC)
IF CD
Begin DoDot:2
+14 ;,N=$S(N:$P(N,U,2,99),1:"")
SET N=$$ICDDATA^ICDXCODE("DIAG",CD,EFFDATE)
+15 SET CD=$PIECE(N,U)
DO WRITECOD^DGPTIC10("DIAG",CD,EFFDATE,1,1,8)
WRITE $SELECT(+N<1!('$PIECE(N,U,10)):"*",1:"")
+16 DO CKSCI^DGPTFM($PIECE(DGZPRF(J,K1),U,DGLOC))
End DoDot:2
IF $Y+$GET(CKSCI)>16
SET PGBRK=1
QUIT
+17 SET PS2(PS2)=J_U_K1
SET CD=1
SET DGLOC=0
SET DGSTRT=4
End DoDot:1
if $Y+$GET(DGZPRF(J,K1+1,1))>16!($GET(PGBRK))
QUIT
+18 IF L1'=11
IF $SELECT(L1<8:$PIECE($GET(DGZPRF(J,K1)),U,L1+1,7),1:"")_$PIECE($GET(DGZPRF(J,K1)),U,$SELECT(L1<8:15,1:L1+8),18)?."^"
SET L1=11
+19 IF L1=11
SET $PIECE(DGZPRF,U,1,2)=$SELECT($DATA(DGZPRF(J,K1+1)):J_U_(K1+1),1:J+1_U_1)
SET $PIECE(DGZPRF,U,4)=""
SET PGBRK=0
+20 IF '$TEST
SET $PIECE(DGZPRF,U,1,2)=J_U_K1
SET $PIECE(DGZPRF,U,4)=L1+1
+21 SET J=+DGZPRF
IF $DATA(DGZPRF(J))
DO HEAD^DGPTFMO
GOTO LOOP
END IF $EXTRACT(IOST)="C"
WRITE !
SET DIR(0)="E"
DO ^DIR
KILL DIR
+1 KILL I,K1,L1,CD,N
QUIT
