APCLFPC1 ; IHS/CMI/LAB - TOP FPR CPTS ;
;;2.0;IHS PCC SUITE;**2**;MAY 14, 2009
VISIT ;
S APCLJOB=$J,APCLBT=$H
K ^XTMP("APCLFPC",APCLJOB,APCLBT)
D XTMP^APCLOSUT("APCLFPC","PCC - FREQ CPT")
S %="^XTMP(""APCLFPC"",APCLJOB,APCLBT,",APCLA=%_"""CPT"",APCLCPT)",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(^AUPNVCPT("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)
CPT S APCLCPTN="",APCLVTOT=APCLVTOT+1,APCLC=0
F S APCLCPTN=$O(^AUPNVCPT("AD",APCLVIEN,APCLCPTN)) Q:'APCLCPTN D
.Q:'$D(^AUPNVCPT(APCLCPTN,0))
.I $D(APCLCPTM),'$D(APCLCPTM($P(^AUPNVCPT(APCLCPTN,0),U))) Q ;not one we want
.S APCLCPT=+^(0),APCLC=APCLC+1,APCLPREC=^(0) D CPTX
Q
;
CPTX I '$D(^ICPT($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 APCLCPT=0:0 S APCLCPT=$O(@APCLA) Q:'APCLCPT S %=^(APCLCPT),@APCLD@(9999999-%,APCLCPT)=""
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
;
APCLFPC1 ; IHS/CMI/LAB - TOP FPR CPTS ;
+1 ;;2.0;IHS PCC SUITE;**2**;MAY 14, 2009
VISIT ;
+1 SET APCLJOB=$JOB
SET APCLBT=$HOROLOG
+2 KILL ^XTMP("APCLFPC",APCLJOB,APCLBT)
+3 DO XTMP^APCLOSUT("APCLFPC","PCC - FREQ CPT")
+4 SET %="^XTMP(""APCLFPC"",APCLJOB,APCLBT,"
SET APCLA=%_"""CPT"",APCLCPT)"
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(^AUPNVCPT("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
CPT SET APCLCPTN=""
SET APCLVTOT=APCLVTOT+1
SET APCLC=0
+1 FOR
SET APCLCPTN=$ORDER(^AUPNVCPT("AD",APCLVIEN,APCLCPTN))
IF 'APCLCPTN
QUIT
Begin DoDot:1
+2 IF '$DATA(^AUPNVCPT(APCLCPTN,0))
QUIT
+3 ;not one we want
IF $DATA(APCLCPTM)
IF '$DATA(APCLCPTM($PIECE(^AUPNVCPT(APCLCPTN,0),U)))
QUIT
+4 SET APCLCPT=+^(0)
SET APCLC=APCLC+1
SET APCLPREC=^(0)
DO CPTX
End DoDot:1
+5 QUIT
+6 ;
CPTX IF '$DATA(^ICPT($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 APCLCPT=0:0
SET APCLCPT=$ORDER(@APCLA)
IF 'APCLCPT
QUIT
SET %=^(APCLCPT)
SET @APCLD@(9999999-%,APCLCPT)=""
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 ;
