- 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 Feb 19, 2025@00:18:23 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