- ABPACDF1 ;PRIV-INS DELETE OPEN CLAIM;[ 05/24/91 1:12 PM ]
- ;;1.4;AO PVT-INS TRACKING;*0*;IHS-OKC/KJR;JULY 25, 1991
- PAT D XIT S ABPA("HD",1)=ABPATLE
- S ABPA("HD",2)="DELETE CLAIMS for a patient" D ^ABPAHD
- W !! D ^ABPAPATL I $D(ABPATDFN)'=1 D XIT Q
- I +ABPATDFN<1 G PAT
- S $P(ABPAX,"=",80)="",ABPAHRN=$P(^ABPVAO(ABPATDFN,0),"^",3)
- S ABPAFAC=$P(^ABPVAO(ABPATDFN,0),"^",2)
- S ABPAL=$E($P(^DIC(4,$P(^ABPVAO(DA,0),U,2),0),U),1,25)
- S $P(ABPAXX,"-",80)="" D ^ABPACDF2
- ;--------------------------------------------------------------------
- ;PROCEDURE TO PROCESS OPEN CLAIMS
- S ABPAC=0 F ABPAI=1:1 D Q:+ABPAC=0 K QFLG D DT3 Q:$D(QFLG)=1
- .S ABPAC=$O(^ABPVAO("CS","O",ABPATDFN,ABPAC))
- S ABPAMESS="End of display...press any key to continue" W !
- D:+ABPAI>1 CONT D PAUSE^ABPAMAIN G PAT
- ;--------------------------------------------------------------------
- DT3 S Y=^ABPVAO(DA,1,ABPAC,0),ABPA(ABPAI,ABPAC)=+Y
- S ABPAINS=$E($P(^AUTNINS($P(Y,U,6),0),U),1,15)
- W !,$J(ABPAI,2),?5,$J("",14-$L(ABPAINS)\2)_ABPAINS,?22,$J((+$E(Y,4,5)_"/"_+$E(Y,6,7)_"/"_+$E(Y,2,3)),8),?33,$J($P(Y,U,7),8,2)
- S ABPASTAT=$P(Y,"^",17)
- W ?43,ABPASTAT,$S(ABPASTAT="C":"LOSED",ABPASTAT="D":"ENIED",ABPASTAT="PA":"ID",ABPASTAT="PE":"NDING",ABPASTAT="O":"PEN",1:"??????")
- I ABPASTAT="PA"!(ABPASTAT="C") S R=0,CNT=0 F I=1:1 D Q:+R=0
- .S R=$O(^ABPVAO(DA,"P",R)) Q:+R=0 S RR=0 F I=1:1 D Q:+RR=0
- ..S RR=$O(^ABPVAO(DA,"P",R,"D",RR)) Q:+RR=0
- ..Q:$D(^ABPVAO(DA,"P",R,"D",RR,0))'=1
- ..Q:+$P(^ABPVAO(DA,"P",R,"D",RR,0),"^",2)'=+ABPAC
- ..S ABPAPDT=+^ABPVAO(DA,"P",R,0)
- ..S ABPAPDT=$J((+$E(ABPAPDT,4,5)_"/"_+$E(ABPAPDT,6,7)_"/"_+$E(ABPAPDT,2,3)),10)
- ..S CNT=CNT+1 W:+CNT>1 ! W ?50,ABPAPDT S RR=0
- ..S RRR=0 F J=1:1 D Q:+RRR=0
- ...S RRR=$O(^ABPVAO(DA,"P",R,"A",RRR)) Q:+RRR=0
- ...Q:$D(^ABPVAO(DA,"P",R,"A",RRR,0))'=1
- ...W:+J>1 ! W ?62,$J(+^ABPVAO(DA,"P",R,"A",RRR,0),10,2)
- ...W " (",$P(^ABPVAO(DA,"P",R,"A",RRR,0),"^",2),")"
- K ABPA("STAT"),R,RR,CNT,I
- I $Y>21 D CONT Q:$D(QFLG)=1 D ^ABPAOCS1
- Q
- ;---------------------------------------------------------------------
- CONT ;PROCEDURE TO PAUSE DISPLAY AND PROCESS ACTION REQUEST
- W !,"Press 'RETURN' to Cont., Select 'List Number' to Delete "
- R "or '^' to Exit ",X:DTIME
- I '$T!(X["^") S QFLG="" Q
- I +X>0 D
- .Q:$D(ABPA(+X))'=10 S ABPAC1=$O(ABPA(X,"")) Q:+ABPAC1=0
- .Q:$D(^ABPVAO(ABPATDFN,1,+ABPAC1,0))'=1
- .S D0=+ABPATDFN,ABPA("CDEL")="" D ^ABPADETC S QFLG=""
- .K DIR S DIR(0)="Y",DIR("A")="Delete this claim - are you sure"
- .K ABPA("CDEL") S DIR("B")="NO" W *7 D ^DIR I Y D
- ..K DIK,DA S DIK="^ABPVAO("_ABPATDFN_",1,",DA(1)=ABPATDFN,DA=ABPAC1
- ..D WAIT^DICD,^DIK K ABPAMESS S ABPAMESS="Claim Deletion Completed!"
- ..S ABPAMESS(2)="...Press any key to continue... " D PAUSE^ABPAMAIN
- Q
- ;---------------------------------------------------------------------
- XIT K ABPARECV,ABPAPD,ABPAENT,ABPADDFN,ABPATDFN,ABPADT,ABPADTD,ABPAPAT,D
- K ABPA,ABPAL,DIC,C,ABPADT,ABPAQKS,ABPAQK,ABPAHRN,ABPARECV,DA,J,K,Z,XQH
- K ABPAC,ABPAI,ABPAXX,ABPAINS,DIE,DR,%DT,ABPAX,ABPAZ,ABPAPDT,QFLG,YY,ZR
- K ABPASTAT
- Q
- ABPACDF1 ;PRIV-INS DELETE OPEN CLAIM;[ 05/24/91 1:12 PM ]
- +1 ;;1.4;AO PVT-INS TRACKING;*0*;IHS-OKC/KJR;JULY 25, 1991
- PAT DO XIT
- SET ABPA("HD",1)=ABPATLE
- +1 SET ABPA("HD",2)="DELETE CLAIMS for a patient"
- DO ^ABPAHD
- +2 WRITE !!
- DO ^ABPAPATL
- IF $DATA(ABPATDFN)'=1
- DO XIT
- QUIT
- +3 IF +ABPATDFN<1
- GOTO PAT
- +4 SET $PIECE(ABPAX,"=",80)=""
- SET ABPAHRN=$PIECE(^ABPVAO(ABPATDFN,0),"^",3)
- +5 SET ABPAFAC=$PIECE(^ABPVAO(ABPATDFN,0),"^",2)
- +6 SET ABPAL=$EXTRACT($PIECE(^DIC(4,$PIECE(^ABPVAO(DA,0),U,2),0),U),1,25)
- +7 SET $PIECE(ABPAXX,"-",80)=""
- DO ^ABPACDF2
- +8 ;--------------------------------------------------------------------
- +9 ;PROCEDURE TO PROCESS OPEN CLAIMS
- +10 SET ABPAC=0
- FOR ABPAI=1:1
- Begin DoDot:1
- +11 SET ABPAC=$ORDER(^ABPVAO("CS","O",ABPATDFN,ABPAC))
- End DoDot:1
- IF +ABPAC=0
- QUIT
- KILL QFLG
- DO DT3
- IF $DATA(QFLG)=1
- QUIT
- +12 SET ABPAMESS="End of display...press any key to continue"
- WRITE !
- +13 IF +ABPAI>1
- DO CONT
- DO PAUSE^ABPAMAIN
- GOTO PAT
- +14 ;--------------------------------------------------------------------
- DT3 SET Y=^ABPVAO(DA,1,ABPAC,0)
- SET ABPA(ABPAI,ABPAC)=+Y
- +1 SET ABPAINS=$EXTRACT($PIECE(^AUTNINS($PIECE(Y,U,6),0),U),1,15)
- +2 WRITE !,$JUSTIFY(ABPAI,2),?5,$JUSTIFY("",14-$LENGTH(ABPAINS)\2)_ABPAINS,?22,$JUSTIFY((+$EXTRACT(Y,4,5)_"/"_+$EXTRACT(Y,6,7)_"/"_+$EXTRACT(Y,2,3)),8),?33,$JUSTIFY($PIECE(Y,U,7),8,2)
- +3 SET ABPASTAT=$PIECE(Y,"^",17)
- +4 WRITE ?43,ABPASTAT,$SELECT(ABPASTAT="C":"LOSED",ABPASTAT="D":"ENIED",ABPASTAT="PA":"ID",ABPASTAT="PE":"NDING",ABPASTAT="O":"PEN",1:"??????")
- +5 IF ABPASTAT="PA"!(ABPASTAT="C")
- SET R=0
- SET CNT=0
- FOR I=1:1
- Begin DoDot:1
- +6 SET R=$ORDER(^ABPVAO(DA,"P",R))
- IF +R=0
- QUIT
- SET RR=0
- FOR I=1:1
- Begin DoDot:2
- +7 SET RR=$ORDER(^ABPVAO(DA,"P",R,"D",RR))
- IF +RR=0
- QUIT
- +8 IF $DATA(^ABPVAO(DA,"P",R,"D",RR,0))'=1
- QUIT
- +9 IF +$PIECE(^ABPVAO(DA,"P",R,"D",RR,0),"^",2)'=+ABPAC
- QUIT
- +10 SET ABPAPDT=+^ABPVAO(DA,"P",R,0)
- +11 SET ABPAPDT=$JUSTIFY((+$EXTRACT(ABPAPDT,4,5)_"/"_+$EXTRACT(ABPAPDT,6,7)_"/"_+$EXTRACT(ABPAPDT,2,3)),10)
- +12 SET CNT=CNT+1
- IF +CNT>1
- WRITE !
- WRITE ?50,ABPAPDT
- SET RR=0
- +13 SET RRR=0
- FOR J=1:1
- Begin DoDot:3
- +14 SET RRR=$ORDER(^ABPVAO(DA,"P",R,"A",RRR))
- IF +RRR=0
- QUIT
- +15 IF $DATA(^ABPVAO(DA,"P",R,"A",RRR,0))'=1
- QUIT
- +16 IF +J>1
- WRITE !
- WRITE ?62,$JUSTIFY(+^ABPVAO(DA,"P",R,"A",RRR,0),10,2)
- +17 WRITE " (",$PIECE(^ABPVAO(DA,"P",R,"A",RRR,0),"^",2),")"
- End DoDot:3
- IF +RRR=0
- QUIT
- End DoDot:2
- IF +RR=0
- QUIT
- End DoDot:1
- IF +R=0
- QUIT
- +18 KILL ABPA("STAT"),R,RR,CNT,I
- +19 IF $Y>21
- DO CONT
- IF $DATA(QFLG)=1
- QUIT
- DO ^ABPAOCS1
- +20 QUIT
- +21 ;---------------------------------------------------------------------
- CONT ;PROCEDURE TO PAUSE DISPLAY AND PROCESS ACTION REQUEST
- +1 WRITE !,"Press 'RETURN' to Cont., Select 'List Number' to Delete "
- +2 READ "or '^' to Exit ",X:DTIME
- +3 IF '$TEST!(X["^")
- SET QFLG=""
- QUIT
- +4 IF +X>0
- Begin DoDot:1
- +5 IF $DATA(ABPA(+X))'=10
- QUIT
- SET ABPAC1=$ORDER(ABPA(X,""))
- IF +ABPAC1=0
- QUIT
- +6 IF $DATA(^ABPVAO(ABPATDFN,1,+ABPAC1,0))'=1
- QUIT
- +7 SET D0=+ABPATDFN
- SET ABPA("CDEL")=""
- DO ^ABPADETC
- SET QFLG=""
- +8 KILL DIR
- SET DIR(0)="Y"
- SET DIR("A")="Delete this claim - are you sure"
- +9 KILL ABPA("CDEL")
- SET DIR("B")="NO"
- WRITE *7
- DO ^DIR
- IF Y
- Begin DoDot:2
- +10 KILL DIK,DA
- SET DIK="^ABPVAO("_ABPATDFN_",1,"
- SET DA(1)=ABPATDFN
- SET DA=ABPAC1
- +11 DO WAIT^DICD
- DO ^DIK
- KILL ABPAMESS
- SET ABPAMESS="Claim Deletion Completed!"
- +12 SET ABPAMESS(2)="...Press any key to continue... "
- DO PAUSE^ABPAMAIN
- End DoDot:2
- End DoDot:1
- +13 QUIT
- +14 ;---------------------------------------------------------------------
- XIT KILL ABPARECV,ABPAPD,ABPAENT,ABPADDFN,ABPATDFN,ABPADT,ABPADTD,ABPAPAT,D
- +1 KILL ABPA,ABPAL,DIC,C,ABPADT,ABPAQKS,ABPAQK,ABPAHRN,ABPARECV,DA,J,K,Z,XQH
- +2 KILL ABPAC,ABPAI,ABPAXX,ABPAINS,DIE,DR,%DT,ABPAX,ABPAZ,ABPAPDT,QFLG,YY,ZR
- +3 KILL ABPASTAT
- +4 QUIT
