Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: APCLNJ12

APCLNJ12.m

Go to the documentation of this file. 
  1. APCLNJ12 ; IHS/CMI/LAB - PRINT VISITS WITH INJURIES ;  
  1.  ;;2.0;IHS PCC SUITE;**11**;MAY 14, 2009;Build 58
  1.  ;
  1.  ;cmi/anch/maw 9/10/2007 code set versioning in PRNT
  1.  ;
  1. INIT ;initialize variables
  1.  S Y=APCLBD D DD^%DT S APCLBDD=Y S Y=APCLED D DD^%DT S APCLEDD=Y
  1.  D ^APCLNJ13 K APCLSTOP,APCLPAGE
  1.  S APCLSTOP="",APCLPAGE=0 D HEAD
  1.  I '$D(^XTMP("APCLNJ1",APCLJOB,APCLBT)) W !,"No injury visits to report."  G END
  1.  ;
  1. SET ;
  1.  S APCLNAME=0
  1.  F  S APCLNAME=$O(^XTMP("APCLNJ1",APCLJOB,APCLBT,APCLNAME)) Q:APCLNAME=""!(APCLSTOP="^")  D SET2
  1. END ;
  1.  D DONE^APCLOSUT
  1.  K ^XTMP("APCLNJ1",APCLJOB,APCLBT),APCLET
  1.  Q
  1. SET2 ;
  1.  S APCLDFN=0
  1.  F  S APCLDFN=$O(^XTMP("APCLNJ1",APCLJOB,APCLBT,APCLNAME,APCLDFN)) Q:APCLDFN'=+APCLDFN  D
  1. SET3 .S APCLVDT=0 F  S APCLVDT=$O(^XTMP("APCLNJ1",APCLJOB,APCLBT,APCLNAME,APCLDFN,APCLVDT)) Q:APCLVDT=""!(APCLSTOP="^")  D SET4
  1.  Q
  1. SET4 ;
  1.  S APCLVDFN=$O(^XTMP("APCLNJ1",APCLJOB,APCLBT,APCLNAME,APCLDFN,APCLVDT,""))
  1.  S APCLHRCN=$S($D(^AUPNPAT(APCLDFN,41,DUZ(2),0)):$P(^(0),U,2),1:"")
  1. SET41 ;
  1.  K ^UTILITY("DIQ1",$J) S DIC=9000001,DA=APCLDFN,DR=1102.99 D EN^DIQ1
  1.  S APCLAGE=$G(^UTILITY("DIQ1",$J,9000001,APCLDFN,1102.99)) K ^UTILITY("DIQ1",$J)
  1.  I $Y>(IOSL-8) D HEAD Q:APCLSTOP="^"
  1.  W !!,$E(APCLNAME,1,20),?22,$J(APCLHRCN,6),?32,$J(APCLAGE,2)
  1.  W ?38,$E(APCLVDT,4,5),"/",$E(APCLVDT,6,7),"/",$E(APCLVDT,2,3)_" "_$E($P(APCLVDT,".",2)_"0000",1,4)
  1.  ;
  1.  S APCLPRV=0
  1. PRV S APCLPRV=$O(^AUPNVPRV("AD",APCLVDFN,APCLPRV))
  1.  I APCLPRV="" S APCLPV=0 G SET5
  1.  G PRV:'$D(^AUPNVPRV(APCLPRV,0)),PRV:$P(^(0),"^",4)'="P"
  1.  S X=+^AUPNVPRV(APCLPRV,0)
  1.  I $P(^DD(9000010.06,.01,0),U,2)[200 S APCLCLS=$$PROVCLSC^XBFUNC1(X) G PRV1
  1.  S X=$P(^DIC(6,X,0),"^",4)
  1.  S APCLCLS=$S(X="":"",'$D(^DIC(7,X,9999999)):"",1:$P(^DIC(7,X,9999999),"^"))
  1. PRV1 W ?54,APCLCLS
  1.  S APCLTYPE=$$EXTSET^XBFUNC(9000010,.03,$P(^AUPNVSIT(APCLVDFN,0),U,3)) W ?60,$E(APCLTYPE,1,9) S APCLSC=$$EXTSET^XBFUNC(9000010,.07,$P(^AUPNVSIT(APCLVDFN,0),U,7)) W ?70,$E(APCLSC,1,10)
  1.  ;
  1.  ;
  1. SET5 ;
  1.  S APCLPOV=0 F  S APCLPOV=$O(^XTMP("APCLNJ1",APCLJOB,APCLBT,APCLNAME,APCLDFN,APCLVDT,APCLVDFN,APCLPOV)) Q:APCLPOV=""!(APCLSTOP="^")  D PRNT
  1.  Q
  1. PRNT ;
  1.  I $Y>(IOSL-8) D HEAD Q:APCLSTOP="^"
  1.  ;W !,"ICD9:  ",$P(^ICD9(+^AUPNVPOV(APCLPOV,0),0),U),?19,"Provider Narrative:  ",$S($P(^AUPNVPOV(APCLPOV,0),U,4):$E($P(^AUTNPOV($P(^AUPNVPOV(APCLPOV,0),U,4),0),U),1,40),1:"????")  ;cmi/anch/maw 9/10/2007 orig line
  1.  W !,"ICD:  ",$P($$ICDDX^ICDEX(+^AUPNVPOV(APCLPOV,0)),U,2),?19,"Provider Narrative:  ",$S($P(^AUPNVPOV(APCLPOV,0),U,4):$E($$VAL^XBDIQ1(9000010.07,APCLPOV,.04),1,40),1:"????")  ;cmi/anch/maw 9/10/2007 csv
  1.  ;I $P(^AUPNVPOV(APCLPOV,0),U,9)]"" W !,"Cause of Injury:  ",?19,$P(^ICD9($P(^AUPNVPOV(APCLPOV,0),U,9),0),U),"  -  ",$P(^(0),U,3)  ;cmi/anch/maw 9/10/2007 orig line
  1.  I $P(^AUPNVPOV(APCLPOV,0),U,9)]"" W !,"Cause of Injury:  ",?19,$P($$ICDDX^ICDEX($P(^AUPNVPOV(APCLPOV,0),U,9)),U,2),"  -  ",$E($P($$ICDDX^ICDEX($P(^AUPNVPOV(APCLPOV,0),U,9)),U,4),1,45)  ;cmi/anch/maw 9/10/2007 csv PATCH 21
  1.  I $P(^AUPNVPOV(APCLPOV,0),U,18)]"" W !,"Cause of Injury #2:  ",?19,$P($$ICDDX^ICDEX($P(^AUPNVPOV(APCLPOV,0),U,18)),U,2),"  -  ",$E($P($$ICDDX^ICDEX($P(^AUPNVPOV(APCLPOV,0),U,18)),U,4),1,45)
  1.  I $P(^AUPNVPOV(APCLPOV,0),U,19)]"" W !,"Cause of Injury #3:  ",?19,$P($$ICDDX^ICDEX($P(^AUPNVPOV(APCLPOV,0),U,19)),U,2),"  -  ",$E($P($$ICDDX^ICDEX($P(^AUPNVPOV(APCLPOV,0),U,19)),U,4),1,45)
  1.  ;W !,"F/R:  " I $P(^AUPNVPOV(APCLPOV,0),U,8)]"" S APCLFR=$$EXTSET^XBFUNC(9000010.07,.08,$P(^AUPNVPOV(APCLPOV,0),U,8)) W APCLFR
  1.  I $P(^AUPNVPOV(APCLPOV,0),U,13)]"" W !,"Date of Injury:  ",?19,$E($P(^AUPNVPOV(APCLPOV,0),U,13),4,5),"/",$E($P(^AUPNVPOV(APCLPOV,0),U,13),6,7),"/",$E($P(^AUPNVPOV(APCLPOV,0),U,13),2,3)
  1.  I $P(^AUPNVPOV(APCLPOV,0),U,11)]"" S APCLPA=$$EXTSET^XBFUNC(9000010.07,.11,$P(^AUPNVPOV(APCLPOV,0),U,11)) W !,"Place of Accident:  ",APCLPA
  1.  I $P(^AUPNVPOV(APCLPOV,0),U,21)]"" W !,"Place of Occurence:  ",?19,$P($$ICDDX^ICDEX($P(^AUPNVPOV(APCLPOV,0),U,21)),U,2),"  -  ",$E($P($$ICDDX^ICDEX($P(^AUPNVPOV(APCLPOV,0),U,21)),U,4),1,45)
  1.  I $P(^AUPNVPOV(APCLPOV,0),U,23)]"" W !,"Retained Foreign Body:  ",?19,$P($$ICDDX^ICDEX($P(^AUPNVPOV(APCLPOV,0),U,23)),U,2),"  -  ",$E($P($$ICDDX^ICDEX($P(^AUPNVPOV(APCLPOV,0),U,23)),U,4),1,45)
  1.  I $P(^AUPNVPOV(APCLPOV,0),U,7)]"" W !,"Cause of DX:  ",$$EXTSET^XBFUNC(9000010.07,.07,$P(^AUPNVPOV(APCLPOV,0),U,7))
  1.  Q
  1.  I $E(IOST)="C",IO=IO(0) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S APCLSTOP="^" Q
  1. HEAD1 ;
  1.  W:$D(IOF) @IOF S APCLPAGE=APCLPAGE+1
  1.  W !
  1.  S X=$P(^DIC(4,DUZ(2),0),"^")
  1.  W !,$P(^VA(200,DUZ,0),"^",2),?(80-$L(X)/2),X,?72,"Page ",APCLPAGE,!
  1.  W ?26,"Visits with Injury Diagnosis",!
  1.  W ?15,"Visit Dates:  ",APCLBDD," to ",APCLEDD
  1.  W !!,"PATIENT",?23,"HRCN",?31,"AGE",?40,"VISIT DATE",?54,"PRV",?60,"TYPE",?70,"SER CAT",!
  1.  W "--------------------------------------------------------------------------------"
  1.  Q
  1. TIME NEW Y,%A,%B,%C S Y="" Q:'$D(X)  Q:X<0!(X>86400)
  1.  S %A=X\60,%B=%A\60 S:%B>12 %B=%B-12 S:%B=0 %B=12 S:%B<10 %B=" "_%B
  1.  S %C=$S(%A=0:"M ",%A=720:"N ",%A=1440:"M ",%A<720:"am",1:"pm")
  1.  S Y=%B_":"_$E(%A#60+100,2,3)_" "_%C K %A,%B,%C Q