ACPT219 ;IHS/OIT/NKD - ACPT V2.19 CPT ENVIRONMENT CHECKER 12/17/18 ;
;;2.19;CPT FILES;;DEC 17, 2018;Build 1
;
I '$G(DUZ) W !,"DUZ UNDEFINED OR 0." D SORRY(2) Q
;
I '$L($G(DUZ(0))) W !,"DUZ(0) UNDEFINED OR NULL." D SORRY(2) Q
;
S X=$P(^VA(200,DUZ,0),U)
W !!,$$CJ^XLFSTR("Hello, "_$P(X,",",2)_" "_$P(X,","),IOM)
N ACPTV,ACPTP
S ACPTV=$P($T(+2),";",3),ACPTP=$P($T(+2),";",5),ACPTP=$S($L(ACPTP)>4:$P(ACPTP,"**",2),1:""),ACPTP=$S(ACPTP]"":$P(ACPTP,",",$L(ACPTP,",")),1:"")
W !!,$$CJ^XLFSTR("Checking Environment for "_$P($T(+2),";",4)_" V "_ACPTV_$S(ACPTP]"":" Patch "_ACPTP,1:"")_".",IOM),!
;
S:'$$VCHK("XU","8.0") XPDQUIT=2
S:'$$VCHK("DI","22.0") XPDQUIT=2
S:'$$VCHK("XT","7.3") XPDQUIT=2
S:'$$VCHK("ACPT","2.18","2") XPDQUIT=2
S:'$$VCHK("BCSV","1.0","3") XPDQUIT=2
;
S:'$$GCHK() XPDQUIT=2
;
I $G(XPDQUIT) W !,$$CJ^XLFSTR("FIX IT! Before Proceeding.",IOM),!!,*7,*7,*7 Q
;
W !!,$$CJ^XLFSTR("ENVIRONMENT OK.",IOM)
;
Q
GCHK() ; Check transport global version
Q:'$D(XPDENV) 1
N ACPTG,ACPTV S ACPTG="ACPT GLOBAL"_$P($G(XPDNM),"ACPT",2),ACPTV=$G(^ACPT(0,"BUILD"))
I '$L(ACPTV) W !,$$CJ^XLFSTR("Transport global not installed or lacks version number! ***FIX IT***",IOM) Q 0
W !,$$CJ^XLFSTR("Need at least "_ACPTG_"....."_ACPTV_" Present"_$S(ACPTV'=ACPTG:" ***FIX IT***",1:""),IOM)
Q $S(ACPTV=ACPTG:1,1:0)
SORRY(X) ;
KILL DIFQ
S XPDQUIT=X
W *7,!,$$CJ^XLFSTR("Sorry....FIX IT!",IOM)
Q
;
VCHK(ACPTPRE,ACPTVER,ACPTPAT) ; Check patch level
N ACPTV,ACPTP
S ACPTV=$$VERSION^XPDUTL(ACPTPRE)
I (ACPTV<ACPTVER) K DIFQ D DISP(ACPTPRE,ACPTVER,$G(ACPTPAT),ACPTV,$G(ACPTP),0) Q 0
I '$D(ACPTPAT) D DISP(ACPTPRE,ACPTVER,$G(ACPTPAT),ACPTV,$G(ACPTP),1) Q 1
S ACPTP=+$$LAST(ACPTPRE,ACPTVER)
I (ACPTP<ACPTPAT) K DIFQ D DISP(ACPTPRE,ACPTVER,$G(ACPTPAT),ACPTVER,$G(ACPTP),0) Q 0
D DISP(ACPTPRE,ACPTVER,$G(ACPTPAT),ACPTVER,$G(ACPTP),1)
Q 1
DISP(ACPTPRE,ACPTVER,ACPTPAT,ACPTV,ACPTP,ACPTR) ; Display requirement checking results
;
N ACPTS
S ACPTS="Need at least "_$G(ACPTPRE)_" v"_$G(ACPTVER)_$S($G(ACPTPAT)]"":" p"_$G(ACPTPAT),1:"")_"....."
S ACPTS=ACPTS_$G(ACPTPRE)_" v"_$G(ACPTV)_$S($G(ACPTP)]"":" p"_$G(ACPTP),1:"")_" Present"
S ACPTS=ACPTS_$S('ACPTR:" ***FIX IT***",1:"")
W !,$$CJ^XLFSTR(ACPTS,IOM)
Q
LAST(PKG,VER) ; EP - returns last patch applied for a Package, PATCH^DATE
; Patch includes Seq # if Released
N PKGIEN,VERIEN,LATEST,PATCH,SUBIEN
I $G(VER)="" S VER=$$VERSION^XPDUTL(PKG) Q:'VER -1
S PKGIEN=$O(^DIC(9.4,"C",PKG,"")) Q:'PKGIEN -1
S VERIEN=$O(^DIC(9.4,PKGIEN,22,"B",VER,"")) Q:'VERIEN -1
S LATEST=-1,PATCH=-1,SUBIEN=0
F S SUBIEN=$O(^DIC(9.4,PKGIEN,22,VERIEN,"PAH",SUBIEN)) Q:SUBIEN'>0 D
. I $P(^DIC(9.4,PKGIEN,22,VERIEN,"PAH",SUBIEN,0),U,2)>LATEST S LATEST=$P(^(0),U,2),PATCH=$P(^(0),U)
. I $P(^DIC(9.4,PKGIEN,22,VERIEN,"PAH",SUBIEN,0),U,2)=LATEST,$P(^(0),U)>PATCH S PATCH=$P(^(0),U)
Q PATCH_U_LATEST
;
PRE ; EP - PRE-INSTALL
; IF ANNUAL UPDATE, RUN PRE-INSTALL UTILITIES
I $L($P($T(+2),";",5))<5 D
. ;D REINDEX
. D CPTCINA
Q
;
POST ; EP - POST-INSTALL
; CALCULATE DEFAULT EFFECTIVE DATE BASED ON VERSION/PATCH
N ACPTYR S ACPTYR=$P($T(+2),";",3)*1000000+1000101+(+$TR($P($T(+2),";",5),"*")*300)
; RUN CPT/HCPCS/CAT UPDATE
D UPDATE^ACPTD
; ANNUAL UPDATE REPORTS
I $L($P($T(+2),";",5))<5 D
. D RSLT^ACPTUTL($$REPEAT^XLFSTR("-",5)_" Annual consistency reports "_$$REPEAT^XLFSTR("-",5),1)
. D DRPT ; DUPLICATES
. D ARPT("CPT") ; ANNUAL CPT
. D ARPT("HCPCS") ; ANNUAL HCPCS
;
I $D(^ACPT("CAT")) D CATUPD^ACPTUTL ; ASSIGN/UPDATE CPT CATEGORIES
K ^ACPT(0),^ACPT("CPT"),^ACPT("HCPCS"),^ACPT("CAT") ; DELETE TRANSPORT GLOBAL AFTER UPDATE
Q
;
REINDEX ; COMPLETE RE-INDEX OF FILES 81, 81.3, AND 81.1
N IND,DA,DIK
D RSLT^ACPTUTL($$REPEAT^XLFSTR("-",5)_" Reindexing CPT file (81)",1)
K DA,DIK
F IND="ACT","ADS","AST","B","BA","C","D","E","F","I" K ^ICPT(IND)
S DIK="^ICPT("
D IXALL^DIK
D RSLT^ACPTUTL($$REPEAT^XLFSTR("-",5)_" Reindexing CPT MODIFIER file (81.3)",1)
K DA,DIK
F IND="ACT","ADS","AST","B","BA","C","D","M" K ^DIC(81.3,IND)
S DIK="^DIC(81.3,"
D IXALL^DIK
D RSLT^ACPTUTL($$REPEAT^XLFSTR("-",5)_" Reindexing CPT CATEGORY file (81.1)",1)
K DA,DIK
F IND="ACPT","B","C","M","R" K ^DIC(81.1,IND)
S DIK="^DIC(81.1,"
D IXALL^DIK
Q
;
CPTCINA ; CORRECT IMPROPERLY INACTIVATED CPT CODES
; Examines the CPT file and inactivates any code that has an Active Date (8) < Inactive Date (7) without an Inactive Flag (5)
D RSLT^ACPTUTL($$REPEAT^XLFSTR("-",5)_" Fixing improperly inactivated CPT codes",1)
N ACPTC,ACPTI,ACPTCNT,FDA
S (ACPTC,ACPTCNT)=0 F S ACPTC=$O(^ICPT("BA",ACPTC)) Q:ACPTC']"" D
. Q:ACPTC="00099 "
. S ACPTI=0 F S ACPTI=$O(^ICPT("BA",ACPTC,ACPTI)) Q:ACPTI']"" D
. . Q:'$D(^ICPT(ACPTI,0))
. . Q:$P(^ICPT(ACPTI,0),U,4)=1
. . Q:$P(^ICPT(ACPTI,0),U,7)']""
. . Q:+$P(^ICPT(ACPTI,0),U,8)>+$P(^ICPT(ACPTI,0),U,7)
. . K FDA
. . S FDA(81,ACPTI_",",5)="1" ; Inactive Flag (5)
. . D UPDATE^DIE(,"FDA",)
. . S ACPTCNT=ACPTCNT+1
. . I '(ACPTCNT#1000) W "."
Q
;
DRPT ; DUPLICATE REPORT - DISPLAY ACTIVE DUPLICATE CODES
N ACPTC,ACPTI,ACPTR
D RSLT^ACPTUTL($$REPEAT^XLFSTR("-",5)_" Duplicate Report: Active duplicate CPT/HCPCS codes",1)
S ACPTC=0 F S ACPTC=$O(^ICPT("BA",ACPTC)) Q:ACPTC']"" D
. S ACPTI=0,ACPTR="" F S ACPTI=$O(^ICPT("BA",ACPTC,ACPTI)) Q:ACPTI']"" D
. . Q:'$D(^ICPT(ACPTI,0)) Q:$P(^ICPT(ACPTI,0),U,4)=1
. . S ACPTR=ACPTR_ACPTI_U
. S:$E(ACPTR,$L(ACPTR))=U ACPTR=$E(ACPTR,1,$L(ACPTR)-1)
. I $L(ACPTR,U)>1 D RSLT^ACPTUTL("CODE: "_ACPTC_$J("",4)_"IENS: "_ACPTR)
Q
;
ARPT(ACPTT) ; ANNUAL REPORT - ACTIVE LOCAL ENTRIES MISSING FROM ANNUAL CODE SET
N ACPTC,ACPTI,ACPTR S ACPTT=$G(ACPTT),ACPTR="" Q:'$L(ACPTT) Q:'$D(^ACPT(ACPTT))
D RSLT^ACPTUTL($$REPEAT^XLFSTR("-",5)_" "_ACPTT_" Report: Active "_ACPTT_" entries not found in annual code set",1)
S ACPTC=0 F S ACPTC=$O(^ICPT("BA",ACPTC)) Q:ACPTC']"" D
. Q:$D(^ACPT(ACPTT,"BA",ACPTC)) Q:$E(ACPTC)="D"
. S ACPTI=0 F S ACPTI=$O(^ICPT("BA",ACPTC,ACPTI)) Q:'ACPTI D
. . Q:'$D(^ICPT(ACPTI,0)) Q:$P(^ICPT(ACPTI,0),U,4)=1 Q:$P(^ICPT(ACPTI,0),U,6)'=$E(ACPTT)
. . S ACPTR=ACPTR_ACPTC_$J("",2)
. . I $L(ACPTR)>79 D RSLT^ACPTUTL(ACPTR) S ACPTR=""
I $L(ACPTR)>0 D RSLT^ACPTUTL(ACPTR)
Q
ACPT219 ;IHS/OIT/NKD - ACPT V2.19 CPT ENVIRONMENT CHECKER 12/17/18 ;
+1 ;;2.19;CPT FILES;;DEC 17, 2018;Build 1
+2 ;
+3 IF '$GET(DUZ)
WRITE !,"DUZ UNDEFINED OR 0."
DO SORRY(2)
QUIT
+4 ;
+5 IF '$LENGTH($GET(DUZ(0)))
WRITE !,"DUZ(0) UNDEFINED OR NULL."
DO SORRY(2)
QUIT
+6 ;
+7 SET X=$PIECE(^VA(200,DUZ,0),U)
+8 WRITE !!,$$CJ^XLFSTR("Hello, "_$PIECE(X,",",2)_" "_$PIECE(X,","),IOM)
+9 NEW ACPTV,ACPTP
+10 SET ACPTV=$PIECE($TEXT(+2),";",3)
SET ACPTP=$PIECE($TEXT(+2),";",5)
SET ACPTP=$SELECT($LENGTH(ACPTP)>4:$PIECE(ACPTP,"**",2),1:"")
SET ACPTP=$SELECT(ACPTP]"":$PIECE(ACPTP,",",$LENGTH(ACPTP,",")),1:"")
+11 WRITE !!,$$CJ^XLFSTR("Checking Environment for "_$PIECE($TEXT(+2),";",4)_" V "_ACPTV_$SELECT(ACPTP]"":" Patch "_ACPTP,1:"")_".",IOM),!
+12 ;
+13 IF '$$VCHK("XU","8.0")
SET XPDQUIT=2
+14 IF '$$VCHK("DI","22.0")
SET XPDQUIT=2
+15 IF '$$VCHK("XT","7.3")
SET XPDQUIT=2
+16 IF '$$VCHK("ACPT","2.18","2")
SET XPDQUIT=2
+17 IF '$$VCHK("BCSV","1.0","3")
SET XPDQUIT=2
+18 ;
+19 IF '$$GCHK()
SET XPDQUIT=2
+20 ;
+21 IF $GET(XPDQUIT)
WRITE !,$$CJ^XLFSTR("FIX IT! Before Proceeding.",IOM),!!,*7,*7,*7
QUIT
+22 ;
+23 WRITE !!,$$CJ^XLFSTR("ENVIRONMENT OK.",IOM)
+24 ;
+25 QUIT
GCHK() ; Check transport global version
+1 IF '$DATA(XPDENV)
QUIT 1
+2 NEW ACPTG,ACPTV
SET ACPTG="ACPT GLOBAL"_$PIECE($GET(XPDNM),"ACPT",2)
SET ACPTV=$GET(^ACPT(0,"BUILD"))
+3 IF '$LENGTH(ACPTV)
WRITE !,$$CJ^XLFSTR("Transport global not installed or lacks version number! ***FIX IT***",IOM)
QUIT 0
+4 WRITE !,$$CJ^XLFSTR("Need at least "_ACPTG_"....."_ACPTV_" Present"_$SELECT(ACPTV'=ACPTG:" ***FIX IT***",1:""),IOM)
+5 QUIT $SELECT(ACPTV=ACPTG:1,1:0)
SORRY(X) ;
+1 KILL DIFQ
+2 SET XPDQUIT=X
+3 WRITE *7,!,$$CJ^XLFSTR("Sorry....FIX IT!",IOM)
+4 QUIT
+5 ;
VCHK(ACPTPRE,ACPTVER,ACPTPAT) ; Check patch level
+1 NEW ACPTV,ACPTP
+2 SET ACPTV=$$VERSION^XPDUTL(ACPTPRE)
+3 IF (ACPTV<ACPTVER)
KILL DIFQ
DO DISP(ACPTPRE,ACPTVER,$GET(ACPTPAT),ACPTV,$GET(ACPTP),0)
QUIT 0
+4 IF '$DATA(ACPTPAT)
DO DISP(ACPTPRE,ACPTVER,$GET(ACPTPAT),ACPTV,$GET(ACPTP),1)
QUIT 1
+5 SET ACPTP=+$$LAST(ACPTPRE,ACPTVER)
+6 IF (ACPTP<ACPTPAT)
KILL DIFQ
DO DISP(ACPTPRE,ACPTVER,$GET(ACPTPAT),ACPTVER,$GET(ACPTP),0)
QUIT 0
+7 DO DISP(ACPTPRE,ACPTVER,$GET(ACPTPAT),ACPTVER,$GET(ACPTP),1)
+8 QUIT 1
DISP(ACPTPRE,ACPTVER,ACPTPAT,ACPTV,ACPTP,ACPTR) ; Display requirement checking results
+1 ;
+2 NEW ACPTS
+3 SET ACPTS="Need at least "_$GET(ACPTPRE)_" v"_$GET(ACPTVER)_$SELECT($GET(ACPTPAT)]"":" p"_$GET(ACPTPAT),1:"")_"....."
+4 SET ACPTS=ACPTS_$GET(ACPTPRE)_" v"_$GET(ACPTV)_$SELECT($GET(ACPTP)]"":" p"_$GET(ACPTP),1:"")_" Present"
+5 SET ACPTS=ACPTS_$SELECT('ACPTR:" ***FIX IT***",1:"")
+6 WRITE !,$$CJ^XLFSTR(ACPTS,IOM)
+7 QUIT
LAST(PKG,VER) ; EP - returns last patch applied for a Package, PATCH^DATE
+1 ; Patch includes Seq # if Released
+2 NEW PKGIEN,VERIEN,LATEST,PATCH,SUBIEN
+3 IF $GET(VER)=""
SET VER=$$VERSION^XPDUTL(PKG)
IF 'VER
QUIT -1
+4 SET PKGIEN=$ORDER(^DIC(9.4,"C",PKG,""))
IF 'PKGIEN
QUIT -1
+5 SET VERIEN=$ORDER(^DIC(9.4,PKGIEN,22,"B",VER,""))
IF 'VERIEN
QUIT -1
+6 SET LATEST=-1
SET PATCH=-1
SET SUBIEN=0
+7 FOR
SET SUBIEN=$ORDER(^DIC(9.4,PKGIEN,22,VERIEN,"PAH",SUBIEN))
IF SUBIEN'>0
QUIT
Begin DoDot:1
+8 IF $PIECE(^DIC(9.4,PKGIEN,22,VERIEN,"PAH",SUBIEN,0),U,2)>LATEST
SET LATEST=$PIECE(^(0),U,2)
SET PATCH=$PIECE(^(0),U)
+9 IF $PIECE(^DIC(9.4,PKGIEN,22,VERIEN,"PAH",SUBIEN,0),U,2)=LATEST
IF $PIECE(^(0),U)>PATCH
SET PATCH=$PIECE(^(0),U)
End DoDot:1
+10 QUIT PATCH_U_LATEST
+11 ;
PRE ; EP - PRE-INSTALL
+1 ; IF ANNUAL UPDATE, RUN PRE-INSTALL UTILITIES
+2 IF $LENGTH($PIECE($TEXT(+2),";",5))<5
Begin DoDot:1
+3 ;D REINDEX
+4 DO CPTCINA
End DoDot:1
+5 QUIT
+6 ;
POST ; EP - POST-INSTALL
+1 ; CALCULATE DEFAULT EFFECTIVE DATE BASED ON VERSION/PATCH
+2 NEW ACPTYR
SET ACPTYR=$PIECE($TEXT(+2),";",3)*1000000+1000101+(+$TRANSLATE($PIECE($TEXT(+2),";",5),"*")*300)
+3 ; RUN CPT/HCPCS/CAT UPDATE
+4 DO UPDATE^ACPTD
+5 ; ANNUAL UPDATE REPORTS
+6 IF $LENGTH($PIECE($TEXT(+2),";",5))<5
Begin DoDot:1
+7 DO RSLT^ACPTUTL($$REPEAT^XLFSTR("-",5)_" Annual consistency reports "_$$REPEAT^XLFSTR("-",5),1)
+8 ; DUPLICATES
DO DRPT
+9 ; ANNUAL CPT
DO ARPT("CPT")
+10 ; ANNUAL HCPCS
DO ARPT("HCPCS")
End DoDot:1
+11 ;
+12 ; ASSIGN/UPDATE CPT CATEGORIES
IF $DATA(^ACPT("CAT"))
DO CATUPD^ACPTUTL
+13 ; DELETE TRANSPORT GLOBAL AFTER UPDATE
KILL ^ACPT(0),^ACPT("CPT"),^ACPT("HCPCS"),^ACPT("CAT")
+14 QUIT
+15 ;
REINDEX ; COMPLETE RE-INDEX OF FILES 81, 81.3, AND 81.1
+1 NEW IND,DA,DIK
+2 DO RSLT^ACPTUTL($$REPEAT^XLFSTR("-",5)_" Reindexing CPT file (81)",1)
+3 KILL DA,DIK
+4 FOR IND="ACT","ADS","AST","B","BA","C","D","E","F","I"
KILL ^ICPT(IND)
+5 SET DIK="^ICPT("
+6 DO IXALL^DIK
+7 DO RSLT^ACPTUTL($$REPEAT^XLFSTR("-",5)_" Reindexing CPT MODIFIER file (81.3)",1)
+8 KILL DA,DIK
+9 FOR IND="ACT","ADS","AST","B","BA","C","D","M"
KILL ^DIC(81.3,IND)
+10 SET DIK="^DIC(81.3,"
+11 DO IXALL^DIK
+12 DO RSLT^ACPTUTL($$REPEAT^XLFSTR("-",5)_" Reindexing CPT CATEGORY file (81.1)",1)
+13 KILL DA,DIK
+14 FOR IND="ACPT","B","C","M","R"
KILL ^DIC(81.1,IND)
+15 SET DIK="^DIC(81.1,"
+16 DO IXALL^DIK
+17 QUIT
+18 ;
CPTCINA ; CORRECT IMPROPERLY INACTIVATED CPT CODES
+1 ; Examines the CPT file and inactivates any code that has an Active Date (8) < Inactive Date (7) without an Inactive Flag (5)
+2 DO RSLT^ACPTUTL($$REPEAT^XLFSTR("-",5)_" Fixing improperly inactivated CPT codes",1)
+3 NEW ACPTC,ACPTI,ACPTCNT,FDA
+4 SET (ACPTC,ACPTCNT)=0
FOR
SET ACPTC=$ORDER(^ICPT("BA",ACPTC))
IF ACPTC']""
QUIT
Begin DoDot:1
+5 IF ACPTC="00099 "
QUIT
+6 SET ACPTI=0
FOR
SET ACPTI=$ORDER(^ICPT("BA",ACPTC,ACPTI))
IF ACPTI']""
QUIT
Begin DoDot:2
+7 IF '$DATA(^ICPT(ACPTI,0))
QUIT
+8 IF $PIECE(^ICPT(ACPTI,0),U,4)=1
QUIT
+9 IF $PIECE(^ICPT(ACPTI,0),U,7)']""
QUIT
+10 IF +$PIECE(^ICPT(ACPTI,0),U,8)>+$PIECE(^ICPT(ACPTI,0),U,7)
QUIT
+11 KILL FDA
+12 ; Inactive Flag (5)
SET FDA(81,ACPTI_",",5)="1"
+13 DO UPDATE^DIE(,"FDA",)
+14 SET ACPTCNT=ACPTCNT+1
+15 IF '(ACPTCNT#1000)
WRITE "."
End DoDot:2
End DoDot:1
+16 QUIT
+17 ;
DRPT ; DUPLICATE REPORT - DISPLAY ACTIVE DUPLICATE CODES
+1 NEW ACPTC,ACPTI,ACPTR
+2 DO RSLT^ACPTUTL($$REPEAT^XLFSTR("-",5)_" Duplicate Report: Active duplicate CPT/HCPCS codes",1)
+3 SET ACPTC=0
FOR
SET ACPTC=$ORDER(^ICPT("BA",ACPTC))
IF ACPTC']""
QUIT
Begin DoDot:1
+4 SET ACPTI=0
SET ACPTR=""
FOR
SET ACPTI=$ORDER(^ICPT("BA",ACPTC,ACPTI))
IF ACPTI']""
QUIT
Begin DoDot:2
+5 IF '$DATA(^ICPT(ACPTI,0))
QUIT
IF $PIECE(^ICPT(ACPTI,0),U,4)=1
QUIT
+6 SET ACPTR=ACPTR_ACPTI_U
End DoDot:2
+7 IF $EXTRACT(ACPTR,$LENGTH(ACPTR))=U
SET ACPTR=$EXTRACT(ACPTR,1,$LENGTH(ACPTR)-1)
+8 IF $LENGTH(ACPTR,U)>1
DO RSLT^ACPTUTL("CODE: "_ACPTC_$JUSTIFY("",4)_"IENS: "_ACPTR)
End DoDot:1
+9 QUIT
+10 ;
ARPT(ACPTT) ; ANNUAL REPORT - ACTIVE LOCAL ENTRIES MISSING FROM ANNUAL CODE SET
+1 NEW ACPTC,ACPTI,ACPTR
SET ACPTT=$GET(ACPTT)
SET ACPTR=""
IF '$LENGTH(ACPTT)
QUIT
IF '$DATA(^ACPT(ACPTT))
QUIT
+2 DO RSLT^ACPTUTL($$REPEAT^XLFSTR("-",5)_" "_ACPTT_" Report: Active "_ACPTT_" entries not found in annual code set",1)
+3 SET ACPTC=0
FOR
SET ACPTC=$ORDER(^ICPT("BA",ACPTC))
IF ACPTC']""
QUIT
Begin DoDot:1
+4 IF $DATA(^ACPT(ACPTT,"BA",ACPTC))
QUIT
IF $EXTRACT(ACPTC)="D"
QUIT
+5 SET ACPTI=0
FOR
SET ACPTI=$ORDER(^ICPT("BA",ACPTC,ACPTI))
IF 'ACPTI
QUIT
Begin DoDot:2
+6 IF '$DATA(^ICPT(ACPTI,0))
QUIT
IF $PIECE(^ICPT(ACPTI,0),U,4)=1
QUIT
IF $PIECE(^ICPT(ACPTI,0),U,6)'=$EXTRACT(ACPTT)
QUIT
+7 SET ACPTR=ACPTR_ACPTC_$JUSTIFY("",2)
+8 IF $LENGTH(ACPTR)>79
DO RSLT^ACPTUTL(ACPTR)
SET ACPTR=""
End DoDot:2
End DoDot:1
+9 IF $LENGTH(ACPTR)>0
DO RSLT^ACPTUTL(ACPTR)
+10 QUIT
