- APCLNJ11 ; IHS/CMI/LAB - PRINT CLINIC VISITS (CALC) ;
- ;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58
- ;
- CALC ;find visits by date then store by patient name
- D XTMP^APCLOSUT("APCLNJ1","PCC INJURY REPORT 1")
- ;
- 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,"^",6)="" ;no location
- G VST1:$P(APCLSTR,"^",7)=""
- 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:APCLDFN="" VST1 ;IHS/CMI/LAB
- 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 I $P($$ICDDX^ICDEX(+^AUPNVPOV(X,0)),U,2)>799.999 D ;cmi/anch/maw 9/10/2007 csv
- NEW X S X=0 F S X=$O(^AUPNVPOV("AD",APCLVDFN,X)) Q:X'=+X I $$INJ^APCDAPOV($$CODEC^ICDEX(80,+^AUPNVPOV(X,0)),$$CSI^ICDEX(80,+^AUPNVPOV(X,0))) D
- .I $D(APCLALCH),APCLALCH="L",$P(^AUPNVPOV(X,0),U,7)'=2 Q
- .S ^XTMP("APCLNJ1",APCLJOB,APCLBT,APCLNAME,APCLDFN,APCLVDT,APCLVDFN,X)=""
- .Q
- Q
- APCLNJ11 ; IHS/CMI/LAB - PRINT CLINIC VISITS (CALC) ;
- +1 ;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58
- +2 ;
- CALC ;find visits by date then store by patient name
- +1 DO XTMP^APCLOSUT("APCLNJ1","PCC INJURY REPORT 1")
- +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 ;no location
- IF $PIECE(APCLSTR,"^",6)=""
- GOTO VST1
- +5 IF $PIECE(APCLSTR,"^",7)=""
- GOTO VST1
- +6 IF $$DEMO^APCLUTL($PIECE(APCLSTR,U,5),$GET(APCLDEMO))
- GOTO VST1
- +7 IF $DATA(APCLLOCT)
- IF '$DATA(APCLLOCT($PIECE(APCLSTR,U,6)))
- GOTO VST1
- +8 IF $DATA(APCLSCT)
- IF '$DATA(APCLSCT($PIECE(APCLSTR,U,7)))
- GOTO VST1
- +9 IF $DATA(APCLTYPT)
- IF '$DATA(APCLTYPT($PIECE(APCLSTR,U,3)))
- GOTO VST1
- +10 IF $DATA(APCLCLNT)
- IF $PIECE(APCLSTR,U,8)=""
- GOTO VST1
- +11 IF $DATA(APCLCLNT)
- IF '$DATA(APCLCLNT($PIECE(APCLSTR,U,8)))
- GOTO VST1
- +12 IF $DATA(APCLAGET)
- IF $$AGE^AUPNPAT($PIECE(APCLSTR,U,5))>$PIECE(APCLAGET,"-",2)
- GOTO VST1
- +13 IF $DATA(APCLAGET)
- IF $$AGE^AUPNPAT($PIECE(APCLSTR,U,5))<$PIECE(APCLAGET,"-",1)
- GOTO VST1
- +14 ;
- +15 ;IHS/CMI/LAB
- SET APCLDFN=$PIECE(APCLSTR,"^",5)
- IF APCLDFN=""
- GOTO VST1
- +16 IF '$DATA(^DPT(APCLDFN,0))
- GOTO VST1
- +17 SET APCLNAME=$PIECE(^DPT(APCLDFN,0),"^")
- +18 DO POV
- +19 GOTO VST1
- +20 ;
- 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 ;NEW X S X=0 F S X=$O(^AUPNVPOV("AD",APCLVDFN,X)) Q:X'=+X I $P($$ICDDX^ICDEX(+^AUPNVPOV(X,0)),U,2)>799.999 D ;cmi/anch/maw 9/10/2007 csv
- +4 NEW X
- SET X=0
- FOR
- SET X=$ORDER(^AUPNVPOV("AD",APCLVDFN,X))
- IF X'=+X
- QUIT
- IF $$INJ^APCDAPOV($$CODEC^ICDEX(80,+^AUPNVPOV(X,0)),$$CSI^ICDEX(80,+^AUPNVPOV(X,0)))
- Begin DoDot:1
- +5 IF $DATA(APCLALCH)
- IF APCLALCH="L"
- IF $PIECE(^AUPNVPOV(X,0),U,7)'=2
- QUIT
- +6 SET ^XTMP("APCLNJ1",APCLJOB,APCLBT,APCLNAME,APCLDFN,APCLVDT,APCLVDFN,X)=""
- +7 QUIT
- End DoDot:1
- +8 QUIT
