source: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/DGPTFM3.m@ 1697

Last change on this file since 1697 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.8 KB
Line 
1DGPTFM3 ;ALB/ADL - MASTER CPT RECORD ENTER/EDIT PART 2 ;5/5/05 7:35am
2 ;;5.3;Registration;**517,590,594,635,696**;Aug 13, 1993
3REQ ;CHECK FOR REQUIRED FIELDS IN CPT RECORDS. RECORDS MISSING ONE OR MORE REQUIRED FIELDS ARE DELETED.
4 S RFL=0 G REQQ:'$D(DGZPRF(DGZP,0))
5 I '$P(^DGPT(PTF,"C",DGZPRF(DGZP,0),0),U,3) S DA(1)=PTF,DA=DGPSM,DIK="^DGPT("_PTF_",""C""," D G REQQ
6 .D ^DIK K DA W !!,"No CPT record has been filed because no performing provider was specified." S RFL=1
7 S (I,FCPT)=0 D RESEQ(PTF)
8 F J=1:1 S I=$O(^DGCPT(46,"C",PTF,I)) Q:'I D:+^DGCPT(46,I,1)=+DGZPRF(DGZP)&'$G(^(9))
9 .I $P(^DGCPT(46,I,0),U,4) S FCPT=1 Q
10 .S DA=I,DIK="^DGCPT(46,",CPT=+^DGCPT(46,I,0) D ^DIK
11 .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."
12 .S RFL=1
13 I FCPT K FCPT,I,J,N G REQQ
14 S DA(1)=PTF,DA=DGZPRF(DGZP,0),DIK="^DGPT("_PTF_",""C"","
15 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
16REQQ ;D RESEQ(PTF)
17 Q ;REQ
18RESEQ(PTF) ;A subroutine to check if a DGN in the DGCPT global has been deleted and the other DGN's need
19 ;to be moved down in sequence to fill the "gap" in the global
20 N REC,CPTINFO,DGNARAY
21 S REC=0
22 F S REC=$O(^DGCPT(46,"C",PTF,REC)) Q:REC="" K DGNARAY S CPTINFO=^DGCPT(46,REC,0) D
23 . F J=4:1:7,15:1:18 S DGNARAY(J)=$P(CPTINFO,U,J)
24 . I $$CHKGAP(.DGNARAY) D RESEQDGN(.CPTINFO,.DGNARAY) S ^DGCPT(46,REC,0)=CPTINFO
25 Q ;RESEQ
26CHKGAP(DGNARAY) ;Function call to determine if an inside DGN code has been deleted
27 ;Back up in the DGNARAY array until a non-null DGN ien is found, then continuing backwards,
28 ;if a null ien is located, that means that an "inside" DGN was deleted
29 S SEQ=999,END=1,MISSING=0
30 F S SEQ=$O(DGNARAY(SEQ),-1) Q:SEQ=""!MISSING D
31 . I DGNARAY(SEQ)'="" S END=1 Q
32 . I DGNARAY(SEQ)="",END=1 S MISSING=1
33 Q MISSING
34 ;
35RESEQDGN(CPTINFO,DGNARAY) ;Subroutine to shift down DGN codes to replace any inside DGN's that were deleted by the user
36 ;
37 N I
38 S SEQ="" K NOTNULL
39 F S SEQ=$O(DGNARAY(SEQ)) Q:SEQ="" I DGNARAY(SEQ)'="" S NOTNULL(SEQ)=DGNARAY(SEQ)
40 K DGNARAY S SEQ=""
41 F I=4:1:7,15:1:18 S DGNARAY(I)=""
42 F I=4:1:7,15:1:18 S SEQ=$O(NOTNULL(SEQ)) Q:SEQ="" S DGNARAY(I)=NOTNULL(SEQ)
43 F I=4:1:7,15:1:18 S $P(CPTINFO,U,I)=$G(DGNARAY(I))
44 K NOTNULL
45 Q ;RESEQDGN
46PF S PTF=D0,DFN=+^DGPT(D0,0) D MOB^DGPTFM2 S PS2=0,J=+DGZPRF
47 G END:'$P(DGZPRF,U,3)
48LOOP S Y=+DGZPRF(J),DGSTRT=$S(+$P(DGZPRF,U,4):$P(DGZPRF,U,4),1:4),DGLST=0
49 D CL^SDCO21(DFN,+DGZPRF(J),"",.SDCLY),ICDINFO^DGAPI(DFN,PTF),XREF^DGPTFM21 ; load SCI info and DGN's for this service date
50 D D^DGPTUTL W !,J,"-CPT Capture Date/Time: ",Y W:($P(DGZPRF,U,2)-1!($G(PGBRK))) " (cont.)"
51 I $P(DGZPRF(J),U,2) W !,?5,"Referring or Ordering Provider: " S L=$P(DGZPRF(J),U,2) D PRV^DGPTFM
52 W !,?5,"Rendering Provider: " S L=$P(DGZPRF(J),U,3) D PRV^DGPTFM
53 I $P(DGZPRF(J),U,5) W !,?5,"Rendering Location: ",$P($G(^SC($P(DGZPRF(J),U,5),0)),U)
54 S (L1,PGBRK)=0
55 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))
56 . S PS2=PS2+1,K=K1 W !,?2,PS2," " D CPT^DGPTUTL1
57 . W !,?4 S $P(DS,"-",27)="" W DS," Related Diagnosis ",DS
58 . 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
59 . . S N=$$ICDDX^ICDCODE(CD,$$GETDATE^ICDGTDRG(PTF)),N=$S(N:$P(N,U,2,99),1:"")
60 . . S CD=$P(N,U) W !,?8,CD," ",$P(N,U,3)
61 . . D CKSCI^DGPTFM($P(DGZPRF(J,K1),U,DGLOC))
62 . S PS2(PS2)=J_U_K1,CD=1,DGLOC=0,DGSTRT=4
63 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
64 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
65 E S $P(DGZPRF,U,1,2)=J_U_K1,$P(DGZPRF,U,4)=L1+1
66 S J=+DGZPRF I $D(DGZPRF(J)) D HEAD^DGPTFMO G LOOP
67END I $E(IOST)="C" W ! S DIR(0)="E" D ^DIR K DIR
68 K I,K1,L1,CD,N Q
Note: See TracBrowser for help on using the repository browser.