- 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
