APCLNJ21 ; IHS/CMI/LAB - PRINT CLINIC VISITS (CALC) ;
;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58
;
;cmi/anch/maw 9/10/2007 code set versioning in POV
;
CALC ;find visits by date then store by patient name
D XTMP^APCLOSUT("APCLNJ2","PCC INJURY REPORT 2")
;
S APCLJOB=$J,APCLBT=$H
S APCLVDT=APCLBD-.0001
VST S APCLVDT=$O(^AUPNVSIT("B",APCLVDT))
G NEXT:APCLVDT="",NEXT:APCLVDT>(APCLED+.2359) S APCLVDFN=0
VST1 S APCLVDFN=$O(^AUPNVSIT("B",APCLVDT,APCLVDFN)) G VST:APCLVDFN=""
;
G VST1:'$D(^AUPNVSIT(APCLVDFN,0)) S APCLSTR=^(0)
G VST1:$P(APCLSTR,"^",11) ;screen out deleted visits
G VST1:$P(APCLSTR,U,5)=""
G VST1:$P(APCLSTR,U,6)=""
G VST1:$P(APCLSTR,U,7)=""
G VST1:$P(APCLSTR,U,3)=""
G VST1:$$DEMO^APCLUTL($P(APCLSTR,U,5),$G(APCLDEMO))
I $D(APCLLOCT),'$D(APCLLOCT($P(APCLSTR,U,6))) G VST1
I $D(APCLSCT),'$D(APCLSCT($P(APCLSTR,U,7))) G VST1
I $D(APCLTYPT),'$D(APCLTYPT($P(APCLSTR,U,3))) G VST1
I $D(APCLCLNT),$P(APCLSTR,U,8)="" G VST1
I $D(APCLCLNT),'$D(APCLCLNT($P(APCLSTR,U,8))) G VST1
I $D(APCLAGET),$$AGE^AUPNPAT($P(APCLSTR,U,5))>$P(APCLAGET,"-",2) G VST1
I $D(APCLAGET),$$AGE^AUPNPAT($P(APCLSTR,U,5))<$P(APCLAGET,"-",1) G VST1
;
S APCLDFN=$P(APCLSTR,"^",5)
G VST1:'$D(^DPT(APCLDFN,0))
S APCLNAME=$P(^DPT(APCLDFN,0),"^")
D POV
G VST1
;
NEXT ;
S APCLET=$H
Q
;
POV ;check to see if pov is injury
;IHS/CMI/LAB - patched line below
;NEW X S X=0 F S X=$O(^AUPNVPOV("AD",APCLVDFN,X)) Q:X'=+X I $P(^ICD9(+^AUPNVPOV(X,0),0),U)>799.999 D ;cmi/anch/maw 9/10/2007 orig line
NEW X S X=0 F S X=$O(^AUPNVPOV("AD",APCLVDFN,X)) Q:X'=+X S %=$P(^AUPNVPOV(X,0),U) I $$INJ^APCDAPOV(%,1)!($$INJ^APCDAPOV(%,30)) D ;cmi/anch/maw 9/10/2007 csv
.S APCLGOT=0
.S APCLCIEN=$P($G(^AUPNVPOV(X,0)),U,9)
.Q:'$D(APCLCIEN)
.S APCLALC=$P($G(^AUPNVPOV(X,0)),U,7)
.F APCLX=1:1:18 S Y="TAX"_APCLX S APCLY=$T(@Y) Q:APCLGOT D S:'$D(APCLCNTR(APCLX,APCLZ)) APCLCNTR(APCLX,APCLZ)="0^0"
..S APCLTXN=$P(APCLY,";;",3)
..S APCLZ=$P(APCLY,";;",2)
..S APCLTAX=$O(^ATXAX("B",APCLTXN,0))
..S %=$$ICD^ATXAPI(APCLCIEN,APCLTAX,9)
..Q:'%
..S APCLGOT=1
..S:'$D(APCLCNTR(APCLX,APCLZ)) APCLCNTR(APCLX,APCLZ)="0^0"
..S $P(APCLCNTR(APCLX,APCLZ),U)=$P(APCLCNTR(APCLX,APCLZ),U)+1
..I APCLALC=2 S $P(APCLCNTR(APCLX,APCLZ),U,2)=$P(APCLCNTR(APCLX,APCLZ),U,2)+1
..I '$D(APCLGTOT) S APCLGTOT=0
..S APCLGTOT=APCLGTOT+1
..I '$D(APCLATOT) S APCLATOT=0
..I APCLALC=2 S APCLATOT=APCLATOT+1
..Q
.Q
;I APCLGOT=0 S APCLNONE=1
Q
;
TAX1 ;;MOTOR VEHICLE;;APCL INJ MOTOR
TAX2 ;;WATER TRANSPORT;;APCL INJ WATER TRANSPORT
TAX3 ;;AIR TRANSPORT;;APCL INJ AIR TRANSPORT
TAX4 ;;ACCIDENTAL POISONING;;APCL INJ POISONING
TAX5 ;;ACCIDENTAL FALLS;;APCL INJ FALLS
TAX6 ;;FIRES/FLAMES;;APCL INJ FIRE
TAX7 ;;ENVIRONMENTAL FACTORS;;APCL INJ ENVIRONMENTAL FACTORS
TAX8 ;;STINGS/VENOMS;;APCL INJ STINGS VENOMS
TAX9 ;;ANIMAL RELATED;;APCL INJ ANIMAL RELATED
TAX10 ;;DROWN/SUBMERGE;;APCL INJ DROWNING
TAX11 ;;CUT PIERCING OBJ;;APCL INJ CUT
TAX12 ;;FIREARMS;;APCL INJ FIREARMS
TAX13 ;;SPORTS INJURY;;APCL INJ SPORTS
TAX14 ;;SUICIDE ATTEMPTS;;APCL INJ SUICIDE
TAX15 ;;ASSAULTS;;APCL INJ ASSAULTS
TAX16 ;;BATTERED CHILD;;APCL INJ BATTERED CHILD
TAX17 ;;UNDETERMINED;;APCL INJ UNDETERMINED
TAX18 ;;OTHER CAUSES;;APCL INJ OTHER CAUSES
APCLNJ21 ; IHS/CMI/LAB - PRINT CLINIC VISITS (CALC) ;
+1 ;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58
+2 ;
+3 ;cmi/anch/maw 9/10/2007 code set versioning in POV
+4 ;
CALC ;find visits by date then store by patient name
+1 DO XTMP^APCLOSUT("APCLNJ2","PCC INJURY REPORT 2")
+2 ;
+3 SET APCLJOB=$JOB
SET APCLBT=$HOROLOG
+4 SET APCLVDT=APCLBD-.0001
VST SET APCLVDT=$ORDER(^AUPNVSIT("B",APCLVDT))
+1 IF APCLVDT=""
GOTO NEXT
IF APCLVDT>(APCLED+.2359)
GOTO NEXT
SET APCLVDFN=0
VST1 SET APCLVDFN=$ORDER(^AUPNVSIT("B",APCLVDT,APCLVDFN))
IF APCLVDFN=""
GOTO VST
+1 ;
+2 IF '$DATA(^AUPNVSIT(APCLVDFN,0))
GOTO VST1
SET APCLSTR=^(0)
+3 ;screen out deleted visits
IF $PIECE(APCLSTR,"^",11)
GOTO VST1
+4 IF $PIECE(APCLSTR,U,5)=""
GOTO VST1
+5 IF $PIECE(APCLSTR,U,6)=""
GOTO VST1
+6 IF $PIECE(APCLSTR,U,7)=""
GOTO VST1
+7 IF $PIECE(APCLSTR,U,3)=""
GOTO VST1
+8 IF $$DEMO^APCLUTL($PIECE(APCLSTR,U,5),$GET(APCLDEMO))
GOTO VST1
+9 IF $DATA(APCLLOCT)
IF '$DATA(APCLLOCT($PIECE(APCLSTR,U,6)))
GOTO VST1
+10 IF $DATA(APCLSCT)
IF '$DATA(APCLSCT($PIECE(APCLSTR,U,7)))
GOTO VST1
+11 IF $DATA(APCLTYPT)
IF '$DATA(APCLTYPT($PIECE(APCLSTR,U,3)))
GOTO VST1
+12 IF $DATA(APCLCLNT)
IF $PIECE(APCLSTR,U,8)=""
GOTO VST1
+13 IF $DATA(APCLCLNT)
IF '$DATA(APCLCLNT($PIECE(APCLSTR,U,8)))
GOTO VST1
+14 IF $DATA(APCLAGET)
IF $$AGE^AUPNPAT($PIECE(APCLSTR,U,5))>$PIECE(APCLAGET,"-",2)
GOTO VST1
+15 IF $DATA(APCLAGET)
IF $$AGE^AUPNPAT($PIECE(APCLSTR,U,5))<$PIECE(APCLAGET,"-",1)
GOTO VST1
+16 ;
+17 SET APCLDFN=$PIECE(APCLSTR,"^",5)
+18 IF '$DATA(^DPT(APCLDFN,0))
GOTO VST1
+19 SET APCLNAME=$PIECE(^DPT(APCLDFN,0),"^")
+20 DO POV
+21 GOTO VST1
+22 ;
NEXT ;
+1 SET APCLET=$HOROLOG
+2 QUIT
+3 ;
POV ;check to see if pov is injury
+1 ;IHS/CMI/LAB - patched line below
+2 ;NEW X S X=0 F S X=$O(^AUPNVPOV("AD",APCLVDFN,X)) Q:X'=+X I $P(^ICD9(+^AUPNVPOV(X,0),0),U)>799.999 D ;cmi/anch/maw 9/10/2007 orig line
+3 ;cmi/anch/maw 9/10/2007 csv
NEW X
SET X=0
FOR
SET X=$ORDER(^AUPNVPOV("AD",APCLVDFN,X))
IF X'=+X
QUIT
SET %=$PIECE(^AUPNVPOV(X,0),U)
IF $$INJ^APCDAPOV(%,1)!($$INJ^APCDAPOV(%,30))
Begin DoDot:1
+4 SET APCLGOT=0
+5 SET APCLCIEN=$PIECE($GET(^AUPNVPOV(X,0)),U,9)
+6 IF '$DATA(APCLCIEN)
QUIT
+7 SET APCLALC=$PIECE($GET(^AUPNVPOV(X,0)),U,7)
+8 FOR APCLX=1:1:18
SET Y="TAX"_APCLX
SET APCLY=$TEXT(@Y)
IF APCLGOT
QUIT
Begin DoDot:2
+9 SET APCLTXN=$PIECE(APCLY,";;",3)
+10 SET APCLZ=$PIECE(APCLY,";;",2)
+11 SET APCLTAX=$ORDER(^ATXAX("B",APCLTXN,0))
+12 SET %=$$ICD^ATXAPI(APCLCIEN,APCLTAX,9)
+13 IF '%
QUIT
+14 SET APCLGOT=1
+15 IF '$DATA(APCLCNTR(APCLX,APCLZ))
SET APCLCNTR(APCLX,APCLZ)="0^0"
+16 SET $PIECE(APCLCNTR(APCLX,APCLZ),U)=$PIECE(APCLCNTR(APCLX,APCLZ),U)+1
+17 IF APCLALC=2
SET $PIECE(APCLCNTR(APCLX,APCLZ),U,2)=$PIECE(APCLCNTR(APCLX,APCLZ),U,2)+1
+18 IF '$DATA(APCLGTOT)
SET APCLGTOT=0
+19 SET APCLGTOT=APCLGTOT+1
+20 IF '$DATA(APCLATOT)
SET APCLATOT=0
+21 IF APCLALC=2
SET APCLATOT=APCLATOT+1
+22 QUIT
End DoDot:2
IF '$DATA(APCLCNTR(APCLX,APCLZ))
SET APCLCNTR(APCLX,APCLZ)="0^0"
+23 QUIT
End DoDot:1
+24 ;I APCLGOT=0 S APCLNONE=1
+25 QUIT
+26 ;
TAX1 ;;MOTOR VEHICLE;;APCL INJ MOTOR
TAX2 ;;WATER TRANSPORT;;APCL INJ WATER TRANSPORT
TAX3 ;;AIR TRANSPORT;;APCL INJ AIR TRANSPORT
TAX4 ;;ACCIDENTAL POISONING;;APCL INJ POISONING
TAX5 ;;ACCIDENTAL FALLS;;APCL INJ FALLS
TAX6 ;;FIRES/FLAMES;;APCL INJ FIRE
TAX7 ;;ENVIRONMENTAL FACTORS;;APCL INJ ENVIRONMENTAL FACTORS
TAX8 ;;STINGS/VENOMS;;APCL INJ STINGS VENOMS
TAX9 ;;ANIMAL RELATED;;APCL INJ ANIMAL RELATED
TAX10 ;;DROWN/SUBMERGE;;APCL INJ DROWNING
TAX11 ;;CUT PIERCING OBJ;;APCL INJ CUT
TAX12 ;;FIREARMS;;APCL INJ FIREARMS
TAX13 ;;SPORTS INJURY;;APCL INJ SPORTS
TAX14 ;;SUICIDE ATTEMPTS;;APCL INJ SUICIDE
TAX15 ;;ASSAULTS;;APCL INJ ASSAULTS
TAX16 ;;BATTERED CHILD;;APCL INJ BATTERED CHILD
TAX17 ;;UNDETERMINED;;APCL INJ UNDETERMINED
TAX18 ;;OTHER CAUSES;;APCL INJ OTHER CAUSES
