ABMDECLN ; IHS/ASDST/DMJ - Clean line itms claim file ;
;;2.6;IHS 3P BILLING SYSTEM;;NOV 12, 2009
;
;IHS/SD/SDR - v2.5 p8 - task 6
; Added code to rebuild new ambulance page 8K
;
; IHS/SD/SDR - v2.5 p10 - IM19901
; Modified to make it leave completed insurers
; instead of rebuilding them, making them active again
;
;Ask user for claim number
N ABMCLM,ABMVDFN
W !
W !,"WARNING this option deletes the data from selected pages (subfiles) of the"
W !,"claim file. Then it looks to see if the data can be rebuilt from PCC."
W !,"For some pages there is no data in PCC. For some the data may be missing."
W !,"The data will only be rebuilt if the information exists in PCC.",!
S DIC="^ABMDCLM(DUZ(2),"
S DIC(0)="AEMNQ"
D ^DIC
Q:Y=-1
S ABMCLM=+Y
K ABM,DTOUT,DUOUT,DIRUT,DIROUT
S Y=$P($G(^ABMDPARM(DUZ(2),1,0)),U,16)
I Y D Q:'Y
.S X1=DT
.S X2=-Y*30.417
.D C^%DTC
.Q:X<$P(^ABMDCLM(DUZ(2),ABMCLM,0),U,2)
.W !,"The date of this claim is prior to the backbilling limit. As a result items"
.W !,"will not be rebuilt from PCC. If you continue, you can only delete items.",!
.S DIR(0)="Y"
.S DIR("A")="Do you wish to continue"
.S DIR("B")="No"
.D ^DIR
K ABM,DTOUT,DUOUT,DIRUT,DIROUT
I '$D(^ABMDCLM(DUZ(2),ABMCLM,11,+$O(^ABMDCLM(DUZ(2),ABMCLM,11,0)),0)) D Q:'Y
.W !,"There are no PCC visits corresponding to this claim. As a result there is no"
.W !,"PCC data to rebuild from. If you continue, you can only delete items.",!
.S DIR(0)="Y"
.S DIR("A")="Do you wish to continue"
.S DIR("B")="No"
.D ^DIR
E D Q:$D(DIRUT)
.S DIR(0)="Y"
.S DIR("A")="Do you wish to view PCC visit information before continuing"
.S DIR("B")="No"
.D ^DIR
.Q:'Y
.S ABMI=0
.F S ABMI=$O(^ABMDCLM(DUZ(2),ABMCLM,11,ABMI)) Q:'ABMI D
..S APCDVDSP=ABMI
..D ^APCDVDSP
.K ABMI,DIR
;Get list of subfiles and display to user.
S DIC="^DD(9002274.3,"
S DR=".01;.2;.4"
S DIQ="ABM" ;DIQ1 puts value into ABM array
S DIQ(0)="I"
F DA=13:2:47 D EN^DIQ1
N PG
F I=0:1:14 D
.S Y=$T(PAGE+I)
.S PG($P(Y,U,2))=$P($P(Y,U),";",3)
W !!
S I=0
F S I=$O(ABM(0,I)) Q:'I D
.Q:ABM(0,I,.2,"I")'["P"
.I $X>35 W !
.E W ?40
.W I," ",ABM(0,I,.01,"I") W:$D(PG(I)) " (P-",PG(I),")"
;Ask user for list of subfiles to clean out
W !
K DIR
S DIR("A")="Enter subfile number or list of subfiles to clean out"
S DIR(0)="LC^13:47:0^K:'$D(ABM(0,+X)) X"
S DIR("?")="Enter one number from the above list or a list or a range."
S DIR("??")="^D HELP^ABMDECLN"
D ^DIR
I $D(DIRUT) G Q
;Clean out the list of selected subfiles
S ABMY=Y
S DA(1)=ABMCLM
F D Q:'ABMY
.S X=$P(ABMY,",",1)
.S ABMY=$P(ABMY,",",2,45)
.I X["-" D
..S ABM1=+X
..S ABM2=$P(X,"-",2)
..F ABM=ABM1:2:ABM2 D:$D(ABM(0,ABM)) CLEANIT(ABM,1)
.E D:$D(ABM(0,X)) CLEANIT(X,1)
S DA=0
F S DA=$O(^ABMDCLM(DUZ(2),DA(1),11,DA)) Q:'DA D
.S ABMVDFN=+^ABMDCLM(DUZ(2),DA(1),11,DA,0)
.S ^AUPNVSIT("ABILL",$P(^AUPNVSIT(ABMVDFN,0),U,2),ABMVDFN)=""
S Y=+^ABMDCLM(DUZ(2),DA(1),0)
I Y D QUEUE^ABMDVPAT
Q ;KILL OFF VARS
K DIR,DIRUT,DTOUT,DUOUT,DIQ,DIC,DA,ABM,ABMY,ABM1,ABM2,DR
Q
;
CLEAN(CLM,SECT,DFN) ;EP to allow cleaning all items from multiple
;CLM = Claim #
;SECT = The multiple to clean out
;Y = Patient DFN
N DA
S DA(1)=CLM
D CLEANIT(SECT,1)
I $G(DFN)>0 S Y=DFN D QUEUE^ABMDVPAT
Q
;
HELP ;EP
W !,"Enter the subfile to clean out for claim # ",ABMCLM,"."
W !,"You may enter a list of subfiles like this: 17,19,23."
W !,"Or a range like this: 23-33, or a combination like this:"
W !,"13,19,23-33. To delete all line items from all mutiples enter"
W !,"13-47"
Q
CLEANIT(ABMSUB,ABMALL) ;EP - Clean out old values from ABMSUB node
N ABMJ,ABMFDA,FILE,IENS
S ABMALL=$G(ABMALL)
S:'$D(DA) DA(1)=ABMP("CDFN")
I $G(ABMCHV0)=$G(ABMP("V0")),$D(^ABMDCLM(DUZ(2),DA(1),ABMSUB))>1 D
.S ABMJ=0
.F S ABMJ=$O(^ABMDCLM(DUZ(2),DA(1),ABMSUB,ABMJ)) Q:'ABMJ D
..Q:'$D(^ABMDCLM(DUZ(2),DA(1),ABMSUB,ABMJ,0))
..S Y=^ABMDCLM(DUZ(2),DA(1),ABMSUB,ABMJ,0)
..I 'ABMALL,($P(Y,U,17)="M") Q
..I ABMSUB=13,$P(Y,U,3)="C" Q ;quit if complete insurer
..S IENS=ABMJ_","_DA(1)_","
..S FILE=9002274.30+(ABMSUB/10000)
..S ABMFDA(FILE,IENS,.01)="@"
..D FILE^DIE("KE","ABMFDA")
..K ABMFDA(FILE)
..Q:'ABMALL
..S ABMSRC=""
..F S ABMSRC=$O(^ABMDCLM(DUZ(2),DA(1),"ASRC",ABMSRC)) Q:ABMSRC="" D
...Q:'$D(^ABMDCLM(DUZ(2),DA(1),"ASRC",ABMSRC,ABMJ))
...K ^ABMDCLM(DUZ(2),DA(1),"ASRC",ABMSRC,ABMJ,ABMSUB)
Q
;
PAGE ;;2^13
;;4^41
;;5A^17
;;5B^19
;;6^33
;;8A^27
;;8B^21
;;8C^25
;;8D^23
;;8E^37
;;8F^35
;;8G^39
;;8H^43
;;8J^45
;;8K^47
ABMDECLN ; IHS/ASDST/DMJ - Clean line itms claim file ;
+1 ;;2.6;IHS 3P BILLING SYSTEM;;NOV 12, 2009
+2 ;
+3 ;IHS/SD/SDR - v2.5 p8 - task 6
+4 ; Added code to rebuild new ambulance page 8K
+5 ;
+6 ; IHS/SD/SDR - v2.5 p10 - IM19901
+7 ; Modified to make it leave completed insurers
+8 ; instead of rebuilding them, making them active again
+9 ;
+10 ;Ask user for claim number
+11 NEW ABMCLM,ABMVDFN
+12 WRITE !
+13 WRITE !,"WARNING this option deletes the data from selected pages (subfiles) of the"
+14 WRITE !,"claim file. Then it looks to see if the data can be rebuilt from PCC."
+15 WRITE !,"For some pages there is no data in PCC. For some the data may be missing."
+16 WRITE !,"The data will only be rebuilt if the information exists in PCC.",!
+17 SET DIC="^ABMDCLM(DUZ(2),"
+18 SET DIC(0)="AEMNQ"
+19 DO ^DIC
+20 IF Y=-1
QUIT
+21 SET ABMCLM=+Y
+22 KILL ABM,DTOUT,DUOUT,DIRUT,DIROUT
+23 SET Y=$PIECE($GET(^ABMDPARM(DUZ(2),1,0)),U,16)
+24 IF Y
Begin DoDot:1
+25 SET X1=DT
+26 SET X2=-Y*30.417
+27 DO C^%DTC
+28 IF X<$PIECE(^ABMDCLM(DUZ(2),ABMCLM,0),U,2)
QUIT
+29 WRITE !,"The date of this claim is prior to the backbilling limit. As a result items"
+30 WRITE !,"will not be rebuilt from PCC. If you continue, you can only delete items.",!
+31 SET DIR(0)="Y"
+32 SET DIR("A")="Do you wish to continue"
+33 SET DIR("B")="No"
+34 DO ^DIR
End DoDot:1
IF 'Y
QUIT
+35 KILL ABM,DTOUT,DUOUT,DIRUT,DIROUT
+36 IF '$DATA(^ABMDCLM(DUZ(2),ABMCLM,11,+$ORDER(^ABMDCLM(DUZ(2),ABMCLM,11,0)),0))
Begin DoDot:1
+37 WRITE !,"There are no PCC visits corresponding to this claim. As a result there is no"
+38 WRITE !,"PCC data to rebuild from. If you continue, you can only delete items.",!
+39 SET DIR(0)="Y"
+40 SET DIR("A")="Do you wish to continue"
+41 SET DIR("B")="No"
+42 DO ^DIR
End DoDot:1
IF 'Y
QUIT
+43 IF '$TEST
Begin DoDot:1
+44 SET DIR(0)="Y"
+45 SET DIR("A")="Do you wish to view PCC visit information before continuing"
+46 SET DIR("B")="No"
+47 DO ^DIR
+48 IF 'Y
QUIT
+49 SET ABMI=0
+50 FOR
SET ABMI=$ORDER(^ABMDCLM(DUZ(2),ABMCLM,11,ABMI))
IF 'ABMI
QUIT
Begin DoDot:2
+51 SET APCDVDSP=ABMI
+52 DO ^APCDVDSP
End DoDot:2
+53 KILL ABMI,DIR
End DoDot:1
IF $DATA(DIRUT)
QUIT
+54 ;Get list of subfiles and display to user.
+55 SET DIC="^DD(9002274.3,"
+56 SET DR=".01;.2;.4"
+57 ;DIQ1 puts value into ABM array
SET DIQ="ABM"
+58 SET DIQ(0)="I"
+59 FOR DA=13:2:47
DO EN^DIQ1
+60 NEW PG
+61 FOR I=0:1:14
Begin DoDot:1
+62 SET Y=$TEXT(PAGE+I)
+63 SET PG($PIECE(Y,U,2))=$PIECE($PIECE(Y,U),";",3)
End DoDot:1
+64 WRITE !!
+65 SET I=0
+66 FOR
SET I=$ORDER(ABM(0,I))
IF 'I
QUIT
Begin DoDot:1
+67 IF ABM(0,I,.2,"I")'["P"
QUIT
+68 IF $X>35
WRITE !
+69 IF '$TEST
WRITE ?40
+70 WRITE I," ",ABM(0,I,.01,"I")
IF $DATA(PG(I))
WRITE " (P-",PG(I),")"
End DoDot:1
+71 ;Ask user for list of subfiles to clean out
+72 WRITE !
+73 KILL DIR
+74 SET DIR("A")="Enter subfile number or list of subfiles to clean out"
+75 SET DIR(0)="LC^13:47:0^K:'$D(ABM(0,+X)) X"
+76 SET DIR("?")="Enter one number from the above list or a list or a range."
+77 SET DIR("??")="^D HELP^ABMDECLN"
+78 DO ^DIR
+79 IF $DATA(DIRUT)
GOTO Q
+80 ;Clean out the list of selected subfiles
+81 SET ABMY=Y
+82 SET DA(1)=ABMCLM
+83 FOR
Begin DoDot:1
+84 SET X=$PIECE(ABMY,",",1)
+85 SET ABMY=$PIECE(ABMY,",",2,45)
+86 IF X["-"
Begin DoDot:2
+87 SET ABM1=+X
+88 SET ABM2=$PIECE(X,"-",2)
+89 FOR ABM=ABM1:2:ABM2
IF $DATA(ABM(0,ABM))
DO CLEANIT(ABM,1)
End DoDot:2
+90 IF '$TEST
IF $DATA(ABM(0,X))
DO CLEANIT(X,1)
End DoDot:1
IF 'ABMY
QUIT
+91 SET DA=0
+92 FOR
SET DA=$ORDER(^ABMDCLM(DUZ(2),DA(1),11,DA))
IF 'DA
QUIT
Begin DoDot:1
+93 SET ABMVDFN=+^ABMDCLM(DUZ(2),DA(1),11,DA,0)
+94 SET ^AUPNVSIT("ABILL",$PIECE(^AUPNVSIT(ABMVDFN,0),U,2),ABMVDFN)=""
End DoDot:1
+95 SET Y=+^ABMDCLM(DUZ(2),DA(1),0)
+96 IF Y
DO QUEUE^ABMDVPAT
Q ;KILL OFF VARS
+1 KILL DIR,DIRUT,DTOUT,DUOUT,DIQ,DIC,DA,ABM,ABMY,ABM1,ABM2,DR
+2 QUIT
+3 ;
CLEAN(CLM,SECT,DFN) ;EP to allow cleaning all items from multiple
+1 ;CLM = Claim #
+2 ;SECT = The multiple to clean out
+3 ;Y = Patient DFN
+4 NEW DA
+5 SET DA(1)=CLM
+6 DO CLEANIT(SECT,1)
+7 IF $GET(DFN)>0
SET Y=DFN
DO QUEUE^ABMDVPAT
+8 QUIT
+9 ;
HELP ;EP
+1 WRITE !,"Enter the subfile to clean out for claim # ",ABMCLM,"."
+2 WRITE !,"You may enter a list of subfiles like this: 17,19,23."
+3 WRITE !,"Or a range like this: 23-33, or a combination like this:"
+4 WRITE !,"13,19,23-33. To delete all line items from all mutiples enter"
+5 WRITE !,"13-47"
+6 QUIT
CLEANIT(ABMSUB,ABMALL) ;EP - Clean out old values from ABMSUB node
+1 NEW ABMJ,ABMFDA,FILE,IENS
+2 SET ABMALL=$GET(ABMALL)
+3 IF '$DATA(DA)
SET DA(1)=ABMP("CDFN")
+4 IF $GET(ABMCHV0)=$GET(ABMP("V0"))
IF $DATA(^ABMDCLM(DUZ(2),DA(1),ABMSUB))>1
Begin DoDot:1
+5 SET ABMJ=0
+6 FOR
SET ABMJ=$ORDER(^ABMDCLM(DUZ(2),DA(1),ABMSUB,ABMJ))
IF 'ABMJ
QUIT
Begin DoDot:2
+7 IF '$DATA(^ABMDCLM(DUZ(2),DA(1),ABMSUB,ABMJ,0))
QUIT
+8 SET Y=^ABMDCLM(DUZ(2),DA(1),ABMSUB,ABMJ,0)
+9 IF 'ABMALL
IF ($PIECE(Y,U,17)="M")
QUIT
+10 ;quit if complete insurer
IF ABMSUB=13
IF $PIECE(Y,U,3)="C"
QUIT
+11 SET IENS=ABMJ_","_DA(1)_","
+12 SET FILE=9002274.30+(ABMSUB/10000)
+13 SET ABMFDA(FILE,IENS,.01)="@"
+14 DO FILE^DIE("KE","ABMFDA")
+15 KILL ABMFDA(FILE)
+16 IF 'ABMALL
QUIT
+17 SET ABMSRC=""
+18 FOR
SET ABMSRC=$ORDER(^ABMDCLM(DUZ(2),DA(1),"ASRC",ABMSRC))
IF ABMSRC=""
QUIT
Begin DoDot:3
+19 IF '$DATA(^ABMDCLM(DUZ(2),DA(1),"ASRC",ABMSRC,ABMJ))
QUIT
+20 KILL ^ABMDCLM(DUZ(2),DA(1),"ASRC",ABMSRC,ABMJ,ABMSUB)
End DoDot:3
End DoDot:2
End DoDot:1
+21 QUIT
+22 ;
PAGE ;;2^13
+1 ;;4^41
+2 ;;5A^17
+3 ;;5B^19
+4 ;;6^33
+5 ;;8A^27
+6 ;;8B^21
+7 ;;8C^25
+8 ;;8D^23
+9 ;;8E^37
+10 ;;8F^35
+11 ;;8G^39
+12 ;;8H^43
+13 ;;8J^45
+14 ;;8K^47
