- LRMIVER ;SLC/CJS/BA - MICROBIOLOGY CHART COPY APPROVAL ;4/24/89 14:42 ;
- ;;5.2;LAB SERVICE;;Sep 27, 1994
- ;from option LRMIVER
- ACCESS D ^LRPARAM I $S('$D(LRLABKY):1,'$P(LRLABKY,U):1,1:0) W "You must have the LRVERIFY key to use this option." Q
- BEGIN S X="N",%DT="T" D ^%DT S LRNT=+Y,LRVT="VS" S LRDAT=LRDT0 D LRAA^LRMIUT I LRAA'<1 D ASK
- END K ^TMP($J),%,%DT,AGE,D,DFN,DOB,DTOUT,DUOUT,I,II,J,K,LAST,LRAA,LRACC,LRAD,LRAN,LRCMNT,LRDAT,LRDFN,LRDONE,LRDPF,LREND,LRIDT,LRVT
- K LRLCNT,LRLLT,LRLST,LRLTR,LRNT,LRONESPC,LRONETST,LRPG,LRSB,LRSET,LRST,LRSTAR,LRTK,LRVLOC,LRWLSAVE,LRWRD,LRWRDVEW,LRYRL,PNM,POP,SEX,SSN,X,Y
- Q
- ASK F I=0:0 W !,"Use previous list" S %=2 D YN^DICN Q:% W !,"Answer 'Y'es or 'N'o"
- I %=1 D LIST,^LRMIVER1 Q
- I %=2 D BUILD
- Q
- LIST W !,"Approving the following:",! S LRAD=0 F I=0:0 S LRAD=+$O(^LRO(68,"AVS",LRAA,LRAD)) Q:LRAD<1 D LIS1
- Q
- LIS1 S LRAN=0 F I=0:0 S LRAN=+$O(^LRO(68,"AVS",LRAA,LRAD,LRAN)) Q:LRAN<1 S LRDFN=+^(LRAN),LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3) D PT^LRX W !,$J(LRAN,6),?8,PNM,?35," ",SSN
- Q
- BUILD K ^LRO(68,"AVS",LRAA) S %DT="AEQ",%DT("A")="Start Date: " D ^%DT K %DT Q:Y<0 S LRSTAR=Y D D^LRU S LRST=Y
- S %DT="AEQ",%DT("A")="End Date: " D ^%DT K %DT Q:Y<0 S LAST=Y D D^LRU S LRLST=Y Q:Y<0 I LRSTAR>LAST S X=LRSTAR,LRSTAR=LAST,LAST=X,X=LRST,LRST=LRLST,LRLST=X
- S Y=LRSTAR D D^LRU S LRST=Y,Y=LAST D D^LRU S LRLST=Y,LRAAT=$P(^LRO(68,LRAA,0),U,3)
- S LRAD=$S(LRAAT="M":$E(LRSTAR,1,3)-2_$E(LRSTAR,4,5)_"00",1:$E(LRSTAR,1,3)-2_"0000"),LRYRL=$S(LRAAT="M":$E(LAST,1,5)_"00",1:$E(LAST,1,3)_"0000"),LAST=LAST\1+.99
- F I=0:0 S LRAD=+$O(^LRO(68,LRAA,1,LRAD)) Q:LRAD<1!(LRAD>LRYRL) D AC
- D ^LRMIVER1
- Q
- AC S LRTK=LRSTAR-1 F I=0:0 S LRTK=+$O(^LRO(68,LRAA,1,LRAD,1,"AD",LRTK)) Q:LRTK<1!(LRTK>LAST) D AC1
- Q
- AC1 S LRAN=0 F I=0:0 S LRAN=+$O(^LRO(68,LRAA,1,LRAD,1,"AD",LRTK,LRAN)) Q:LRAN<1 I $D(^LRO(68,LRAA,1,LRAD,1,LRAN,0)) D OK
- Q
- OK Q:'$D(^LRO(68,LRAA,1,LRAD,1,LRAN,3)) S LRDONE=$P(^(3),U,4) Q:LRDONE
- S LRIDT=9999999-^LRO(68,LRAA,1,LRAD,1,LRAN,3),LRDFN=+^(0),LRSET=0 F II=1,5,8,11,16 D FINAL
- W:'LRSET "." I LRSET S ^LRO(68,"AVS",LRAA,LRAD,LRAN)=LRDFN_U_LRIDT S LRDPF=$P(^LR(LRDFN,0),U,2),DFN=$P(^(0),U,3) D PT^LRX W !,$J(LRAN,6),?8,PNM,?35," ",SSN,?80
- Q
- FINAL I $D(^LR(LRDFN,"MI",LRIDT,II)),+^(II),$P(^(II),U,2)="F" S LRSET=1
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HLRMIVER 2304 printed Feb 18, 2025@23:43:40 Page 2
- LRMIVER ;SLC/CJS/BA - MICROBIOLOGY CHART COPY APPROVAL ;4/24/89 14:42 ;
- +1 ;;5.2;LAB SERVICE;;Sep 27, 1994
- +2 ;from option LRMIVER
- ACCESS DO ^LRPARAM
- IF $SELECT('$DATA(LRLABKY):1,'$PIECE(LRLABKY,U):1,1:0)
- WRITE "You must have the LRVERIFY key to use this option."
- QUIT
- BEGIN SET X="N"
- SET %DT="T"
- DO ^%DT
- SET LRNT=+Y
- SET LRVT="VS"
- SET LRDAT=LRDT0
- DO LRAA^LRMIUT
- IF LRAA'<1
- DO ASK
- END KILL ^TMP($JOB),%,%DT,AGE,D,DFN,DOB,DTOUT,DUOUT,I,II,J,K,LAST,LRAA,LRACC,LRAD,LRAN,LRCMNT,LRDAT,LRDFN,LRDONE,LRDPF,LREND,LRIDT,LRVT
- +1 KILL LRLCNT,LRLLT,LRLST,LRLTR,LRNT,LRONESPC,LRONETST,LRPG,LRSB,LRSET,LRST,LRSTAR,LRTK,LRVLOC,LRWLSAVE,LRWRD,LRWRDVEW,LRYRL,PNM,POP,SEX,SSN,X,Y
- +2 QUIT
- ASK FOR I=0:0
- WRITE !,"Use previous list"
- SET %=2
- DO YN^DICN
- if %
- QUIT
- WRITE !,"Answer 'Y'es or 'N'o"
- +1 IF %=1
- DO LIST
- DO ^LRMIVER1
- QUIT
- +2 IF %=2
- DO BUILD
- +3 QUIT
- LIST WRITE !,"Approving the following:",!
- SET LRAD=0
- FOR I=0:0
- SET LRAD=+$ORDER(^LRO(68,"AVS",LRAA,LRAD))
- if LRAD<1
- QUIT
- DO LIS1
- +1 QUIT
- LIS1 SET LRAN=0
- FOR I=0:0
- SET LRAN=+$ORDER(^LRO(68,"AVS",LRAA,LRAD,LRAN))
- if LRAN<1
- QUIT
- SET LRDFN=+^(LRAN)
- SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)
- SET DFN=$PIECE(^(0),U,3)
- DO PT^LRX
- WRITE !,$JUSTIFY(LRAN,6),?8,PNM,?35," ",SSN
- +1 QUIT
- BUILD KILL ^LRO(68,"AVS",LRAA)
- SET %DT="AEQ"
- SET %DT("A")="Start Date: "
- DO ^%DT
- KILL %DT
- if Y<0
- QUIT
- SET LRSTAR=Y
- DO D^LRU
- SET LRST=Y
- +1 SET %DT="AEQ"
- SET %DT("A")="End Date: "
- DO ^%DT
- KILL %DT
- if Y<0
- QUIT
- SET LAST=Y
- DO D^LRU
- SET LRLST=Y
- if Y<0
- QUIT
- IF LRSTAR>LAST
- SET X=LRSTAR
- SET LRSTAR=LAST
- SET LAST=X
- SET X=LRST
- SET LRST=LRLST
- SET LRLST=X
- +2 SET Y=LRSTAR
- DO D^LRU
- SET LRST=Y
- SET Y=LAST
- DO D^LRU
- SET LRLST=Y
- SET LRAAT=$PIECE(^LRO(68,LRAA,0),U,3)
- +3 SET LRAD=$SELECT(LRAAT="M":$EXTRACT(LRSTAR,1,3)-2_$EXTRACT(LRSTAR,4,5)_"00",1:$EXTRACT(LRSTAR,1,3)-2_"0000")
- SET LRYRL=$SELECT(LRAAT="M":$EXTRACT(LAST,1,5)_"00",1:$EXTRACT(LAST,1,3)_"0000")
- SET LAST=LAST\1+.99
- +4 FOR I=0:0
- SET LRAD=+$ORDER(^LRO(68,LRAA,1,LRAD))
- if LRAD<1!(LRAD>LRYRL)
- QUIT
- DO AC
- +5 DO ^LRMIVER1
- +6 QUIT
- AC SET LRTK=LRSTAR-1
- FOR I=0:0
- SET LRTK=+$ORDER(^LRO(68,LRAA,1,LRAD,1,"AD",LRTK))
- if LRTK<1!(LRTK>LAST)
- QUIT
- DO AC1
- +1 QUIT
- AC1 SET LRAN=0
- FOR I=0:0
- SET LRAN=+$ORDER(^LRO(68,LRAA,1,LRAD,1,"AD",LRTK,LRAN))
- if LRAN<1
- QUIT
- IF $DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,0))
- DO OK
- +1 QUIT
- OK if '$DATA(^LRO(68,LRAA,1,LRAD,1,LRAN,3))
- QUIT
- SET LRDONE=$PIECE(^(3),U,4)
- if LRDONE
- QUIT
- +1 SET LRIDT=9999999-^LRO(68,LRAA,1,LRAD,1,LRAN,3)
- SET LRDFN=+^(0)
- SET LRSET=0
- FOR II=1,5,8,11,16
- DO FINAL
- +2 if 'LRSET
- WRITE "."
- IF LRSET
- SET ^LRO(68,"AVS",LRAA,LRAD,LRAN)=LRDFN_U_LRIDT
- SET LRDPF=$PIECE(^LR(LRDFN,0),U,2)
- SET DFN=$PIECE(^(0),U,3)
- DO PT^LRX
- WRITE !,$JUSTIFY(LRAN,6),?8,PNM,?35," ",SSN,?80
- +3 QUIT
- FINAL IF $DATA(^LR(LRDFN,"MI",LRIDT,II))
- IF +^(II)
- IF $PIECE(^(II),U,2)="F"
- SET LRSET=1
- +1 QUIT
