- APCLFPR1 ; IHS/CMI/LAB - TOP FPR PRCS ;
- ;;2.0;IHS PCC SUITE;;MAY 14, 2009
- VISIT ;
- S APCLJOB=$J,APCLBT=$H
- K ^XTMP("APCLFPR",APCLJOB,APCLBT)
- D XTMP^APCLOSUT("APCLFPR","PCC - FREQ PROC")
- S %="^XTMP(""APCLFPR"",APCLJOB,APCLBT,",APCLA=%_"""PRC"",APCLPRC)",APCLD=%_"1)",APCLF=%_"3)",APCLTOT=0,APCLVTOT=0,APCLLINO=0,APCLGTOT=0
- S APCLDATE=APCLBD-.00001
- F S APCLDATE=$O(^AUPNVSIT("B",APCLDATE)) Q:'APCLDATE Q:(APCLDATE\1)>APCLED D
- .F APCLVIEN=0:0 S APCLVIEN=$O(^AUPNVSIT("B",APCLDATE,APCLVIEN)) Q:'APCLVIEN S APCLGTOT=APCLGTOT+1 I $D(^AUPNVSIT(APCLVIEN,0)),$D(^AUPNVPRC("AD",APCLVIEN)) D CK
- D SET
- S APCLET=$H
- Q
- ;
- CK ;
- S APCLVREC=^AUPNVSIT(APCLVIEN,0),DFN=$P(APCLVREC,U,5) Q:$$DEMO^APCLUTL(DFN,$G(APCLDEMO))
- Q:$P(APCLVREC,U,11)
- Q:'$P(APCLVREC,U,9)
- D SCREENS
- Q:$D(APCLSKIP)
- PRC S APCLPRCN="",APCLVTOT=APCLVTOT+1,APCLC=0
- F S APCLPRCN=$O(^AUPNVPRC("AD",APCLVIEN,APCLPRCN)) Q:'APCLPRCN Q:'$D(^AUPNVPRC(APCLPRCN,0)) S APCLPRC=+^(0),APCLC=APCLC+1,APCLPREC=^(0) D PRCX
- Q
- ;
- PRCX I '$D(^ICD0($P(APCLPREC,U))) Q
- S APCLTOT=APCLTOT+1
- F X=APCLA D UTL
- Q
- ;
- UTL ;I X=B,'$D(APCLAPC) Q
- I '$D(@X) S @X=0
- S %=@X,%=%+1,@X=%
- Q
- ;
- SCREENS ;
- K APCLSKIP
- S APCLI=0 F S APCLI=$O(^APCLVRPT(APCLRPT,11,APCLI)) Q:APCLI'=+APCLI!($D(APCLSKIP)) D
- .I '$P(^APCLVSTS(APCLI,0),U,8) D SINGLE Q
- .D MULT
- .Q
- Q
- SINGLE ;
- K X,APCLSPEC S X="",APCLX=0
- X:$D(^APCLVSTS(APCLI,1)) ^(1)
- I X="" S APCLSKIP="" Q
- I '$D(APCLSPEC),'$D(^APCLVRPT(APCLRPT,11,APCLI,11,"B",X)) S APCLSKIP="" Q
- Q
- MULT ;
- K APCLFOUN,APCLSKIP,APCLSPEC,X S APCLX=0,X=""
- X:$D(^APCLVSTS(APCLI,1)) ^(1)
- I $O(X(""))="" S APCLSKIP="" Q
- I '$D(APCLSPEC) S Y="" F S Y=$O(X(Y)) Q:Y="" I $D(^APCLVRPT(APCLRPT,11,APCLI,11,"B",Y)) S APCLFOUN="" Q
- I $D(APCLSPEC),$D(X) S APCLFOUN=1 Q
- S:'$D(APCLFOUN) APCLSKIP=""
- Q
- SET F APCLPRC=0:0 S APCLPRC=$O(@APCLA) Q:'APCLPRC S %=^(APCLPRC),@APCLD@(9999999-%,APCLPRC)=""
- S1 S (X,I)=0 F S X=$O(@APCLD@(X)) Q:'X F Y=0:0 S Y=$O(@APCLD@(X,Y)) Q:'Y S I=I+1,@APCLF@(I)=Y I I=APCLLNO G S3
- S3 Q
- ;
- ;
- FF I IOST["P-" W:$D(IOF) @IOF Q
- I $E(IOST)="C",IO=IO(0),$Y>(IOSL-4) W ! S DIR(0)="EO" D ^DIR K DIR I Y=0!(Y="^")!($D(DTOUT)) S X="^"
- W:$D(IOF) @IOF
- Q
- ;
- APCLFPR1 ; IHS/CMI/LAB - TOP FPR PRCS ;
- +1 ;;2.0;IHS PCC SUITE;;MAY 14, 2009
- VISIT ;
- +1 SET APCLJOB=$JOB
- SET APCLBT=$HOROLOG
- +2 KILL ^XTMP("APCLFPR",APCLJOB,APCLBT)
- +3 DO XTMP^APCLOSUT("APCLFPR","PCC - FREQ PROC")
- +4 SET %="^XTMP(""APCLFPR"",APCLJOB,APCLBT,"
- SET APCLA=%_"""PRC"",APCLPRC)"
- SET APCLD=%_"1)"
- SET APCLF=%_"3)"
- SET APCLTOT=0
- SET APCLVTOT=0
- SET APCLLINO=0
- SET APCLGTOT=0
- +5 SET APCLDATE=APCLBD-.00001
- +6 FOR
- SET APCLDATE=$ORDER(^AUPNVSIT("B",APCLDATE))
- IF 'APCLDATE
- QUIT
- IF (APCLDATE\1)>APCLED
- QUIT
- Begin DoDot:1
- +7 FOR APCLVIEN=0:0
- SET APCLVIEN=$ORDER(^AUPNVSIT("B",APCLDATE,APCLVIEN))
- IF 'APCLVIEN
- QUIT
- SET APCLGTOT=APCLGTOT+1
- IF $DATA(^AUPNVSIT(APCLVIEN,0))
- IF $DATA(^AUPNVPRC("AD",APCLVIEN))
- DO CK
- End DoDot:1
- +8 DO SET
- +9 SET APCLET=$HOROLOG
- +10 QUIT
- +11 ;
- CK ;
- +1 SET APCLVREC=^AUPNVSIT(APCLVIEN,0)
- SET DFN=$PIECE(APCLVREC,U,5)
- IF $$DEMO^APCLUTL(DFN,$GET(APCLDEMO))
- QUIT
- +2 IF $PIECE(APCLVREC,U,11)
- QUIT
- +3 IF '$PIECE(APCLVREC,U,9)
- QUIT
- +4 DO SCREENS
- +5 IF $DATA(APCLSKIP)
- QUIT
- PRC SET APCLPRCN=""
- SET APCLVTOT=APCLVTOT+1
- SET APCLC=0
- +1 FOR
- SET APCLPRCN=$ORDER(^AUPNVPRC("AD",APCLVIEN,APCLPRCN))
- IF 'APCLPRCN
- QUIT
- IF '$DATA(^AUPNVPRC(APCLPRCN,0))
- QUIT
- SET APCLPRC=+^(0)
- SET APCLC=APCLC+1
- SET APCLPREC=^(0)
- DO PRCX
- +2 QUIT
- +3 ;
- PRCX IF '$DATA(^ICD0($PIECE(APCLPREC,U)))
- QUIT
- +1 SET APCLTOT=APCLTOT+1
- +2 FOR X=APCLA
- DO UTL
- +3 QUIT
- +4 ;
- UTL ;I X=B,'$D(APCLAPC) Q
- +1 IF '$DATA(@X)
- SET @X=0
- +2 SET %=@X
- SET %=%+1
- SET @X=%
- +3 QUIT
- +4 ;
- SCREENS ;
- +1 KILL APCLSKIP
- +2 SET APCLI=0
- FOR
- SET APCLI=$ORDER(^APCLVRPT(APCLRPT,11,APCLI))
- IF APCLI'=+APCLI!($DATA(APCLSKIP))
- QUIT
- Begin DoDot:1
- +3 IF '$PIECE(^APCLVSTS(APCLI,0),U,8)
- DO SINGLE
- QUIT
- +4 DO MULT
- +5 QUIT
- End DoDot:1
- +6 QUIT
- SINGLE ;
- +1 KILL X,APCLSPEC
- SET X=""
- SET APCLX=0
- +2 IF $DATA(^APCLVSTS(APCLI,1))
- XECUTE ^(1)
- +3 IF X=""
- SET APCLSKIP=""
- QUIT
- +4 IF '$DATA(APCLSPEC)
- IF '$DATA(^APCLVRPT(APCLRPT,11,APCLI,11,"B",X))
- SET APCLSKIP=""
- QUIT
- +5 QUIT
- MULT ;
- +1 KILL APCLFOUN,APCLSKIP,APCLSPEC,X
- SET APCLX=0
- SET X=""
- +2 IF $DATA(^APCLVSTS(APCLI,1))
- XECUTE ^(1)
- +3 IF $ORDER(X(""))=""
- SET APCLSKIP=""
- QUIT
- +4 IF '$DATA(APCLSPEC)
- SET Y=""
- FOR
- SET Y=$ORDER(X(Y))
- IF Y=""
- QUIT
- IF $DATA(^APCLVRPT(APCLRPT,11,APCLI,11,"B",Y))
- SET APCLFOUN=""
- QUIT
- +5 IF $DATA(APCLSPEC)
- IF $DATA(X)
- SET APCLFOUN=1
- QUIT
- +6 IF '$DATA(APCLFOUN)
- SET APCLSKIP=""
- +7 QUIT
- SET FOR APCLPRC=0:0
- SET APCLPRC=$ORDER(@APCLA)
- IF 'APCLPRC
- QUIT
- SET %=^(APCLPRC)
- SET @APCLD@(9999999-%,APCLPRC)=""
- S1 SET (X,I)=0
- FOR
- SET X=$ORDER(@APCLD@(X))
- IF 'X
- QUIT
- FOR Y=0:0
- SET Y=$ORDER(@APCLD@(X,Y))
- IF 'Y
- QUIT
- SET I=I+1
- SET @APCLF@(I)=Y
- IF I=APCLLNO
- GOTO S3
- S3 QUIT
- +1 ;
- +2 ;
- FF IF IOST["P-"
- IF $DATA(IOF)
- WRITE @IOF
- QUIT
- +1 IF $EXTRACT(IOST)="C"
- IF IO=IO(0)
- IF $Y>(IOSL-4)
- WRITE !
- SET DIR(0)="EO"
- DO ^DIR
- KILL DIR
- IF Y=0!(Y="^")!($DATA(DTOUT))
- SET X="^"
- +2 IF $DATA(IOF)
- WRITE @IOF
- +3 QUIT
- +4 ;
