AZP3APC ;REPORT FOR PRIVATE INSURANCE ELIGIBLE APC VISITS [ 11/09/90 7:58 AM ]
;FCJ 11/1/90
VAR S DFN=0,U="^"
S %ZIS("A")="Enter the device to print APC Report on: " D ^%ZIS,NOW^%DTC S DT=X
A S %DT("A")="Enter beginning date for Report. ",%DT="AE" D ^%DT G:Y<0 EXIT S BDOS=Y-1
A1 S %DT("A")="Enter ending date for Report. " D ^%DT S EDOS=Y
I EDOS="" S EDOS=DT I EDOS'?1N.N W !,"YOU MUST ENTER AN ENDING DATE..." G A1
I EDOS<BDOS W !,"BEGINNING DATE MUST IS AFTER ENDING DATE OF REPORT" G A
S Y=EDOS X ^DD("DD") S EDT=Y,Y=BDOS X ^DD("DD") S BDT=Y
BEG D HEAD F S DFN=$O(^AUPNPRVT(DFN)) G:DFN'?1N.N EXIT D
.Q:'$D(^AAPCRCDS("B",DFN)) S NM=$P(^DPT(DFN,0),U),ND=0
.S INS=0,TST=0 F L=1:1 S INS=$O(^AUPNPRVT(DFN,11,INS)) Q:INS'?1N.N S INS(L)=$P(^AUPNPRVT(DFN,11,INS,0),U)_U_$P(^(0),U,6,7) S $P(INS(L),U)=$P(^AUTNINS($P(INS(L),U),0),U)
.S L=L-1 F S ND=$O(^AAPCRCDS("B",DFN,ND)) Q:ND'?1N.N S DOS=$P(^AAPCRCDS(ND,0),U,3),FAC=$P(^(0),U,2),CL=$P(^(0),U,13),HRN=$P(^(0),U,5) S:$D(^AAPCRCDS(ND,3,1,0)) PROB=$P(^AAPCRCDS(ND,3,1,0),U,1) D
..Q:(DOS<BDOS)!(DOS>EDOS) F L1=1:1:L S BELG=$P(INS(L1),U,2)-1,EELG=$P(INS(L1),U,3)+1 I ((DOS>BELG)&(DOS<EELG))!((DOS>BELG)&(EELG=1))!((BELG<0)&(DOS<EELG))!((BELG<0)&(EELG=1)) D:TST=0 HEAD1,INS D
...S Y=DOS X ^DD("DD") S DOS(FAC,ND)=$P(^DIC(4,FAC,0),U)_U_Y_U_$P(^DIC("40.7",CL,0),U)_U_$P(^AAPCRECD(PROB,0),U,1)_U_$P(^AAPCRECD(PROB,0),U,2)
.S FAC=0,FAC1=0 F S FAC=$O(DOS(FAC)),DOSND=0 Q:FAC="" D HEAD2 F S DOSND=$O(DOS(FAC,DOSND)) Q:DOSND'?1N.N D:$Y>55 HEAD,HEAD1,HEAD2 W:FAC'=FAC1 $P(DOS(FAC,DOSND),U) D
..W ?22,$P(DOS(FAC,DOSND),U,2),?40,$P(DOS(FAC,DOSND),U,3),?54,$P(DOS(FAC,DOSND),U,4),?65,$P(DOS(FAC,DOSND),U,5),! S FAC1=FAC
.K DOS,INS
HEAD U IO W @IOF,!?15,"APC REPORT FOR ELIGIBLE PRIVATE INSURANCE PATIENTS",!!?20,"BEGINNING ",BDT," THROUGH ",EDT,! Q
HEAD1 W !!,"PATIENT NAME: ",NM,?45,"HEALTH RECORD NUMBER: ",HRN,! S TST=1 Q
HEAD2 W !,"FACILITY",?20,"DATE OF SERVICE",?40,"CLINIC",?50,"PROBLEM CODE",?64,"ICD9 CODE",!,"--------",?20,"---------------",?40,"------",?50,"------------",?64,"---------",! Q
INS F L1=1:1:L S Y=$P(INS(L1),U,2) X ^DD("DD") S BELG=Y S Y=$P(INS(L1),U,3) X ^DD("DD") S EELG=Y W "INS: ",$P(INS(L1),U),?40,"BEG: ",BELG,?60,"END: ",EELG,!
Q
EXIT K BELG,EELG,L,L1,TST,%DT,X,Y,BDOS,EDOS,EDT,BDT,DOSND,ND,DFN,NM,CL,FAC,FAC1 X ^%ZIS("C") Q
AZP3APC ;REPORT FOR PRIVATE INSURANCE ELIGIBLE APC VISITS [ 11/09/90 7:58 AM ]
+1 ;FCJ 11/1/90
VAR SET DFN=0
SET U="^"
+1 SET %ZIS("A")="Enter the device to print APC Report on: "
DO ^%ZIS
DO NOW^%DTC
SET DT=X
A SET %DT("A")="Enter beginning date for Report. "
SET %DT="AE"
DO ^%DT
IF Y<0
GOTO EXIT
SET BDOS=Y-1
A1 SET %DT("A")="Enter ending date for Report. "
DO ^%DT
SET EDOS=Y
+1 IF EDOS=""
SET EDOS=DT
IF EDOS'?1N.N
WRITE !,"YOU MUST ENTER AN ENDING DATE..."
GOTO A1
+2 IF EDOS<BDOS
WRITE !,"BEGINNING DATE MUST IS AFTER ENDING DATE OF REPORT"
GOTO A
+3 SET Y=EDOS
XECUTE ^DD("DD")
SET EDT=Y
SET Y=BDOS
XECUTE ^DD("DD")
SET BDT=Y
BEG DO HEAD
FOR
SET DFN=$ORDER(^AUPNPRVT(DFN))
IF DFN'?1N.N
GOTO EXIT
Begin DoDot:1
+1 IF '$DATA(^AAPCRCDS("B",DFN))
QUIT
SET NM=$PIECE(^DPT(DFN,0),U)
SET ND=0
+2 SET INS=0
SET TST=0
FOR L=1:1
SET INS=$ORDER(^AUPNPRVT(DFN,11,INS))
IF INS'?1N.N
QUIT
SET INS(L)=$PIECE(^AUPNPRVT(DFN,11,INS,0),U)_U_$PIECE(^(0),U,6,7)
SET $PIECE(INS(L),U)=$PIECE(^AUTNINS($PIECE(INS(L),U),0),U)
+3 SET L=L-1
FOR
SET ND=$ORDER(^AAPCRCDS("B",DFN,ND))
IF ND'?1N.N
QUIT
SET DOS=$PIECE(^AAPCRCDS(ND,0),U,3)
SET FAC=$PIECE(^(0),U,2)
SET CL=$PIECE(^(0),U,13)
SET HRN=$PIECE(^(0),U,5)
IF $DATA(^AAPCRCDS(ND,3,1,0))
SET PROB=$PIECE(^AAPCRCDS(ND,3,1,0),U,1)
Begin DoDot:2
+4 IF (DOS<BDOS)!(DOS>EDOS)
QUIT
FOR L1=1:1:L
SET BELG=$PIECE(INS(L1),U,2)-1
SET EELG=$PIECE(INS(L1),U,3)+1
IF ((DOS>BELG)&(DOS<EELG))!((DOS>BELG)&(EELG=1))!((BELG<0)&(DOS<EELG))!((BELG<0)&(EELG=1))
IF TST=0
DO HEAD1
DO INS
Begin DoDot:3
+5 SET Y=DOS
XECUTE ^DD("DD")
SET DOS(FAC,ND)=$PIECE(^DIC(4,FAC,0),U)_U_Y_U_$PIECE(^DIC("40.7",CL,0),U)_U_$PIECE(^AAPCRECD(PROB,0),U,1)_U_$PIECE(^AAPCRECD(PROB,0),U,2)
End DoDot:3
End DoDot:2
+6 SET FAC=0
SET FAC1=0
FOR
SET FAC=$ORDER(DOS(FAC))
SET DOSND=0
IF FAC=""
QUIT
DO HEAD2
FOR
SET DOSND=$ORDER(DOS(FAC,DOSND))
IF DOSND'?1N.N
QUIT
IF $Y>55
DO HEAD
DO HEAD1
DO HEAD2
IF FAC'=FAC1
WRITE $PIECE(DOS(FAC,DOSND),U)
Begin DoDot:2
+7 WRITE ?22,$PIECE(DOS(FAC,DOSND),U,2),?40,$PIECE(DOS(FAC,DOSND),U,3),?54,$PIECE(DOS(FAC,DOSND),U,4),?65,$PIECE(DOS(FAC,DOSND),U,5),!
SET FAC1=FAC
End DoDot:2
+8 KILL DOS,INS
End DoDot:1
HEAD USE IO
WRITE @IOF,!?15,"APC REPORT FOR ELIGIBLE PRIVATE INSURANCE PATIENTS",!!?20,"BEGINNING ",BDT," THROUGH ",EDT,!
QUIT
HEAD1 WRITE !!,"PATIENT NAME: ",NM,?45,"HEALTH RECORD NUMBER: ",HRN,!
SET TST=1
QUIT
HEAD2 WRITE !,"FACILITY",?20,"DATE OF SERVICE",?40,"CLINIC",?50,"PROBLEM CODE",?64,"ICD9 CODE",!,"--------",?20,"---------------",?40,"------",?50,"------------",?64,"---------",!
QUIT
INS FOR L1=1:1:L
SET Y=$PIECE(INS(L1),U,2)
XECUTE ^DD("DD")
SET BELG=Y
SET Y=$PIECE(INS(L1),U,3)
XECUTE ^DD("DD")
SET EELG=Y
WRITE "INS: ",$PIECE(INS(L1),U),?40,"BEG: ",BELG,?60,"END: ",EELG,!
+1 QUIT
EXIT KILL BELG,EELG,L,L1,TST,%DT,X,Y,BDOS,EDOS,EDT,BDT,DOSND,ND,DFN,NM,CL,FAC,FAC1
XECUTE ^%ZIS("C")
QUIT
