source: WorldVistAEHR/trunk/r/LAB_SERVICE-LR-LS/LRAPQOR2.m@ 1661

Last change on this file since 1661 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 1.6 KB
RevLine 
[613]1LRAPQOR2 ;AVAMC/REG/CYM - QA AUTOPSY DATA ;2/13/97 07:52
2 ;;5.2;LAB SERVICE;**155**;Sep 27, 1994
3 D FIELD^DID(63,14.5,"","POINTER","LRS") S LRS=LRS("POINTER")_"?:?;" D H1
4 F LRA=0:0 S LRA=$O(^TMP($J,LRA)) Q:'LRA!(LR("Q")) S LRM=0,LRB=$S($D(^LAB(62.5,LRA,0)):^(0),1:"??") D:$Y>(IOSL-6) H1 Q:LR("Q") W !!,$P(LRB,U),?5,$P(LRB,U,2) D S
5 Q:LR("Q") D ^LRAPQOR3 Q
6S S LRI="" F S LRI=$O(^TMP($J,"S",LRA,LRI)) Q:LRI=""!(LR("Q")) D:$Y>(IOSL-6) H2 Q:LR("Q") S LRK=LRI_":",LRK=$P($P(LRS,LRK,2),";") W !!?5,"SERVICE: ",LRK D T
7 Q:LR("Q") W !,"Total QA Codes for ",$P(LRB,U),": ",LRM Q
8T S LRL="" F S LRL=$O(^TMP($J,"S",LRA,LRI,LRL)) Q:LRL=""!(LR("Q")) D:$Y>(IOSL-6) H3 Q:LR("Q") S LRL(1)=$S(LRL="?":"?",1:$P($G(^DIC(45.7,LRL,0)),U)) W !?7,"TREATING SPECIALTY: ",LRL(1) D M
9 Q
10M S LRP="" F S LRP=$O(^TMP($J,"S",LRA,LRI,LRL,LRP)) Q:LRP=""!(LR("Q")) D:$Y>(IOSL-6) H4 Q:LR("Q") S LRP(1)=$S(LRP="?":"?",1:$P($G(^VA(200,LRP,0)),U)) W !?10,"CLINICIAN: ",LRP(1) D A
11 Q
12A S LRC=0 F S LRC=$O(^TMP($J,"S",LRA,LRI,LRL,LRP,LRC)) Q:'LRC D
13 . Q:(LR("Q"))>0
14 . S LRY=$$FMTE^XLFDT(LRC,"D"),LRD=""
15 . S LRF=0 F S LRF=$O(^TMP($J,"S",LRA,LRI,LRL,LRP,LRC,LRF)) Q:LRF']"" D
16 .. Q:(LR("Q"))>0 D W Q
17 Q
18W D:$Y>(IOSL-6) H5 Q:LR("Q") W !?13,"Autopsy: ",$J(LRF,4),?35,"Date: ",LRY S LRM=LRM+1 Q
19 D ^LRAPQOR3 Q
20H I $D(LR("F")),IOST?1"C".E D M^LRU Q:LR("Q")
21 D F^LRU W !,"QA CODES by SERVICE, TREATING SPECIALTY and CLINICIAN",!,"From ",LRSTR," To ",LRLST Q
22H1 D H Q:LR("Q") W !,LR("%") Q
23H2 D H1 Q:LR("Q") W !,$P(LRB,U),?5,$P(LRB,U,2) Q
24H3 D H2 Q:LR("Q") W !!?5,"SERVICE: ",LRK Q
25H4 D H3 Q:LR("Q") W !?7,"TREATING SPECIALTY: ",LRL(1) Q
26H5 D H4 Q:LR("Q") W !?10,"CLINICIAN: ",LRP(1) Q
Note: See TracBrowser for help on using the repository browser.