BWPCC2 ;IHS/ANMC/MWR - WOMEN'S HEALTH PCC LINK;15-Feb-2003 22:07;PLS
;;2.0;WOMEN'S HEALTH;**8,13**;APR 19, 1996;Build 9
;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
;; SELECT AND PRINT THE POINTERS OF WOMEN'S HEALTH PROCEDURES TO
;; TABLE FILES: ICD OP/PROC, LAB TEST, EXAM, RADIOLOGY PROCEDURES.
;
EDIT ;EP
;---> EDIT PROCEDURE PCC .01 POINTERS.
D SETVARS^BWUTL5
N A,DR,Y
F D Q:$G(Y)<0
.D TITLE^BWUTL5("EDIT WOMEN'S HEALTH PROCEDURE POINTERS")
.S A=" Select WOMEN'S HEALTH PROCEDURE: "
.D DIC^BWFMAN(9002086.2,"QEMAZ",.Y,A)
.Q:Y<0
.S BWVFIL=$P(Y(0),U,12)
.I 'BWVFIL D Q
..W !!?5,"This procedure is not set up for export to PCC."
..D DIRZ^BWUTL3 K Y
.D
..I BWVFIL=9000010.08 S DR=".14" Q
..I BWVFIL=9000010.09 S DR=".15" Q
..I BWVFIL=9000010.13 S DR=".16" Q
..I BWVFIL=9000010.22 S DR=".17" Q
..I BWVFIL=9000010.18 S DR=".08" Q
.D DIE^BWFMAN(9002086.2,DR,+Y,.BWPOP)
.D DIRZ^BWUTL3
D EXIT
Q
;
;
PRINT ;EP
;---> DISPLAY PROCEDURE PCC .01 POINTERS.
D SETUP
D TITLE^BWUTL5("PROCEDURE TYPES AND THEIR PCC .01 VALUES")
D DEVICE Q:BWPOP
D DATA
D DISPLAY
D EXIT
Q
;
SETUP ;EP
D SETVARS^BWUTL5 S BWPOP=0
S BWLINE="-" F I=1:1:79 S BWLINE=BWLINE_"-"
Q
;
DEVICE ;EP
;---> GET DEVICE AND POSSIBLY QUEUE TO TASKMAN.
S ZTRTN="DEQUEUE^BWPCC2"
D ZIS^BWUTL2(.BWPOP,1)
Q
;
;
DISPLAY ;EP
U IO
S BWTITLE1="* WOMEN'S HEALTH: "
S BWTITLE1=BWTITLE1_"PROCEDURE TYPES AND THEIR PCC .01 VALUES *"
D CENTERT^BWUTL5(.BWTITLE1)
S BWCRT=$S($E(IOST)="C":1,1:0),(BWPAGE,BWPOP)=0
S BWSUB="W !?3,""WH PROCEDURE"",?29,""PCC .01 VALUE"""
S BWSUB=BWSUB_",?64,""PCC TABLE FILE"""
;
S (BWPOP,N,Z)=0
W:BWCRT @IOF D HEADER
F S N=$O(^TMP("BW",$J,N)) Q:'N!(BWPOP) D
.I $Y+8>IOSL D:BWCRT DIRZ^BWUTL3 Q:BWPOP D HEADER
.W !!,^TMP("BW",$J,N,0)
I BWCRT&('BWPOP) W !! D DIRZ^BWUTL3
W:'BWCRT @IOF
D ^%ZISC
K ^TMP("BW",$J)
Q
;
W:BWPAGE @IOF S BWPAGE=BWPAGE+1
W !,BWTITLE1,?71,"PAGE ",BWPAGE
W !,BWLINE X BWSUB W !,BWLINE
Q
;
DEQUEUE ;EP
;---> CALLED BY TASKMAN
D SETUP,DATA,DISPLAY,EXIT
Q
;
DATA ;EP
;---> SORT PROCEDURE TYPE FILE POINTERS.
N BWNODE,N,P,X,Y,Z K ^TMP("BW",$J)
;---> LOOP THROUGH BW PROCEDURE FILE.
S N=0
F I=1:1 S N=$O(^BWPN("B",N)) Q:N="" D
.;
.S Y=$O(^BWPN("B",N,0)),Y=^BWPN(Y,0),BWNODE=""
.S BWNODE=$E($P(Y,U),1,24)
.;
.;---> X=V FILE POINTER.
.S X=$P(Y,U,12)
.I 'X S BWNODE=BWNODE_U_"NOT SET UP FOR PCC"
.;
.;---> Z=PCC TABLE FILE POINTER.
.S Z=0
.I X D
..Q:'$D(^DD(X,.01,0))
..S Z=+$P($P(^DD(X,.01,0),U,2),"P",2)
.I ('Z)&(X) S BWNODE=BWNODE_U_"PROBLEM W/FILE"
.;
.;---> P=PCC TABLE FILE GLOBAL.
.S:Z P=^DIC(Z,0,"GL")
.D:(X&(Z))
..;---> V PROCEDURE PTR.
..I X=9000010.08 D Q
...I '$P(Y,U,14) S BWNODE=BWNODE_U_"POINTER VALUE NOT SELECTED" Q
...S BWNODE=BWNODE_U_$E($P(@(P_$P(Y,U,14)_",0)"),U,4),1,24)
...S BWNODE=BWNODE_" ("_$P(@(P_$P(Y,U,14)_",0)"),U)_")" Q
..;
..;---> V LAB PTR.
..I X=9000010.09 D Q
...I '$P(Y,U,15) S BWNODE=BWNODE_U_"POINTER VALUE NOT SELECTED" Q
...S BWNODE=BWNODE_U_$P(@(P_$P(Y,U,15)_",0)"),U) Q
..;
..;---> V EXAM PTR.
..I X=9000010.13 D Q
...I '$P(Y,U,16) S BWNODE=BWNODE_U_"POINTER VALUE NOT SELECTED" Q
...S BWNODE=BWNODE_U_$P(@(P_$P(Y,U,16)_",0)"),U)
...S BWNODE=BWNODE_" ("_$P(@(P_$P(Y,U,16)_",0)"),U,2)_")"
..;
..;---> V RADIOLOGY PTR.
..I X=9000010.22 D Q
...I '$P(Y,U,17) S BWNODE=BWNODE_U_"POINTER VALUE NOT SELECTED" Q
...S P=P_$P(Y,U,17)_",0)" I '$D(@P) D Q
....S BWNODE=BWNODE_U_"POINTED TO ENTRY DOES NOT EXIST"
...S BWNODE=BWNODE_U_$E($P(@(P),U),1,24)
...S BWNODE=BWNODE_" ("_$P(@(P),U,9)_")"
..;---> V CPT PTR
..I X=9000010.18 D Q
...I '$P(Y,U,8) S BWNODE=BWNODE_U_"POINTER VALUE NOT SELECTED" Q
...S P=P_$P(Y,U,8)_",0)" I '$D(@P) D Q
....S BWNODE=BWNODE_U_"POINTED TO ENTRY DOES NOT EXIST"
...S BWNODE=BWNODE_U_$E($P(@(P),U,2),1,24)
...S BWNODE=BWNODE_" ("_$P(@(P),U)_")" Q
..;
..;---> NOTHING.
..S BWNODE=BWNODE_U
.;
.S:(X&(Z)) BWNODE=BWNODE_U_$E($P(^DIC(Z,0),U),1,15)
.;
.D FORMAT(.BWNODE)
.S ^TMP("BW",$J,I,0)=BWNODE
Q
;
FORMAT(Y) ;EP
;---> INSERT NECESSARY SPACING FOR COLUMNS.
N A,B,C
S A=$P(Y,U),B=$P(Y,U,2),C=$P(Y,U,3)
S Y=" "_A_$$S(26-$L(A))_B_$$S(35-$L(B))_C
Q
;
S(S) ;EP
;---> SPACES.
Q $$S^BWUTL7($G(S))
;
EXIT ;EP
D KILLALL^BWUTL8
Q
BWPCC2 ;IHS/ANMC/MWR - WOMEN'S HEALTH PCC LINK;15-Feb-2003 22:07;PLS
+1 ;;2.0;WOMEN'S HEALTH;**8,13**;APR 19, 1996;Build 9
+2 ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
+3 ;; SELECT AND PRINT THE POINTERS OF WOMEN'S HEALTH PROCEDURES TO
+4 ;; TABLE FILES: ICD OP/PROC, LAB TEST, EXAM, RADIOLOGY PROCEDURES.
+5 ;
EDIT ;EP
+1 ;---> EDIT PROCEDURE PCC .01 POINTERS.
+2 DO SETVARS^BWUTL5
+3 NEW A,DR,Y
+4 FOR
Begin DoDot:1
+5 DO TITLE^BWUTL5("EDIT WOMEN'S HEALTH PROCEDURE POINTERS")
+6 SET A=" Select WOMEN'S HEALTH PROCEDURE: "
+7 DO DIC^BWFMAN(9002086.2,"QEMAZ",.Y,A)
+8 IF Y<0
QUIT
+9 SET BWVFIL=$PIECE(Y(0),U,12)
+10 IF 'BWVFIL
Begin DoDot:2
+11 WRITE !!?5,"This procedure is not set up for export to PCC."
+12 DO DIRZ^BWUTL3
KILL Y
End DoDot:2
QUIT
+13 Begin DoDot:2
+14 IF BWVFIL=9000010.08
SET DR=".14"
QUIT
+15 IF BWVFIL=9000010.09
SET DR=".15"
QUIT
+16 IF BWVFIL=9000010.13
SET DR=".16"
QUIT
+17 IF BWVFIL=9000010.22
SET DR=".17"
QUIT
+18 IF BWVFIL=9000010.18
SET DR=".08"
QUIT
End DoDot:2
+19 DO DIE^BWFMAN(9002086.2,DR,+Y,.BWPOP)
+20 DO DIRZ^BWUTL3
End DoDot:1
IF $GET(Y)<0
QUIT
+21 DO EXIT
+22 QUIT
+23 ;
+24 ;
PRINT ;EP
+1 ;---> DISPLAY PROCEDURE PCC .01 POINTERS.
+2 DO SETUP
+3 DO TITLE^BWUTL5("PROCEDURE TYPES AND THEIR PCC .01 VALUES")
+4 DO DEVICE
IF BWPOP
QUIT
+5 DO DATA
+6 DO DISPLAY
+7 DO EXIT
+8 QUIT
+9 ;
SETUP ;EP
+1 DO SETVARS^BWUTL5
SET BWPOP=0
+2 SET BWLINE="-"
FOR I=1:1:79
SET BWLINE=BWLINE_"-"
+3 QUIT
+4 ;
DEVICE ;EP
+1 ;---> GET DEVICE AND POSSIBLY QUEUE TO TASKMAN.
+2 SET ZTRTN="DEQUEUE^BWPCC2"
+3 DO ZIS^BWUTL2(.BWPOP,1)
+4 QUIT
+5 ;
+6 ;
DISPLAY ;EP
+1 USE IO
+2 SET BWTITLE1="* WOMEN'S HEALTH: "
+3 SET BWTITLE1=BWTITLE1_"PROCEDURE TYPES AND THEIR PCC .01 VALUES *"
+4 DO CENTERT^BWUTL5(.BWTITLE1)
+5 SET BWCRT=$SELECT($EXTRACT(IOST)="C":1,1:0)
SET (BWPAGE,BWPOP)=0
+6 SET BWSUB="W !?3,""WH PROCEDURE"",?29,""PCC .01 VALUE"""
+7 SET BWSUB=BWSUB_",?64,""PCC TABLE FILE"""
+8 ;
+9 SET (BWPOP,N,Z)=0
+10 IF BWCRT
WRITE @IOF
DO HEADER
+11 FOR
SET N=$ORDER(^TMP("BW",$JOB,N))
IF 'N!(BWPOP)
QUIT
Begin DoDot:1
+12 IF $Y+8>IOSL
IF BWCRT
DO DIRZ^BWUTL3
IF BWPOP
QUIT
DO HEADER
+13 WRITE !!,^TMP("BW",$JOB,N,0)
End DoDot:1
+14 IF BWCRT&('BWPOP)
WRITE !!
DO DIRZ^BWUTL3
+15 IF 'BWCRT
WRITE @IOF
+16 DO ^%ZISC
+17 KILL ^TMP("BW",$JOB)
+18 QUIT
+19 ;
+1 IF BWPAGE
WRITE @IOF
SET BWPAGE=BWPAGE+1
+2 WRITE !,BWTITLE1,?71,"PAGE ",BWPAGE
+3 WRITE !,BWLINE
XECUTE BWSUB
WRITE !,BWLINE
+4 QUIT
+5 ;
DEQUEUE ;EP
+1 ;---> CALLED BY TASKMAN
+2 DO SETUP
DO DATA
DO DISPLAY
DO EXIT
+3 QUIT
+4 ;
DATA ;EP
+1 ;---> SORT PROCEDURE TYPE FILE POINTERS.
+2 NEW BWNODE,N,P,X,Y,Z
KILL ^TMP("BW",$JOB)
+3 ;---> LOOP THROUGH BW PROCEDURE FILE.
+4 SET N=0
+5 FOR I=1:1
SET N=$ORDER(^BWPN("B",N))
IF N=""
QUIT
Begin DoDot:1
+6 ;
+7 SET Y=$ORDER(^BWPN("B",N,0))
SET Y=^BWPN(Y,0)
SET BWNODE=""
+8 SET BWNODE=$EXTRACT($PIECE(Y,U),1,24)
+9 ;
+10 ;---> X=V FILE POINTER.
+11 SET X=$PIECE(Y,U,12)
+12 IF 'X
SET BWNODE=BWNODE_U_"NOT SET UP FOR PCC"
+13 ;
+14 ;---> Z=PCC TABLE FILE POINTER.
+15 SET Z=0
+16 IF X
Begin DoDot:2
+17 IF '$DATA(^DD(X,.01,0))
QUIT
+18 SET Z=+$PIECE($PIECE(^DD(X,.01,0),U,2),"P",2)
End DoDot:2
+19 IF ('Z)&(X)
SET BWNODE=BWNODE_U_"PROBLEM W/FILE"
+20 ;
+21 ;---> P=PCC TABLE FILE GLOBAL.
+22 IF Z
SET P=^DIC(Z,0,"GL")
+23 IF (X&(Z))
Begin DoDot:2
+24 ;---> V PROCEDURE PTR.
+25 IF X=9000010.08
Begin DoDot:3
+26 IF '$PIECE(Y,U,14)
SET BWNODE=BWNODE_U_"POINTER VALUE NOT SELECTED"
QUIT
+27 SET BWNODE=BWNODE_U_$EXTRACT($PIECE(@(P_$PIECE(Y,U,14)_",0)"),U,4),1,24)
+28 SET BWNODE=BWNODE_" ("_$PIECE(@(P_$PIECE(Y,U,14)_",0)"),U)_")"
QUIT
End DoDot:3
QUIT
+29 ;
+30 ;---> V LAB PTR.
+31 IF X=9000010.09
Begin DoDot:3
+32 IF '$PIECE(Y,U,15)
SET BWNODE=BWNODE_U_"POINTER VALUE NOT SELECTED"
QUIT
+33 SET BWNODE=BWNODE_U_$PIECE(@(P_$PIECE(Y,U,15)_",0)"),U)
QUIT
End DoDot:3
QUIT
+34 ;
+35 ;---> V EXAM PTR.
+36 IF X=9000010.13
Begin DoDot:3
+37 IF '$PIECE(Y,U,16)
SET BWNODE=BWNODE_U_"POINTER VALUE NOT SELECTED"
QUIT
+38 SET BWNODE=BWNODE_U_$PIECE(@(P_$PIECE(Y,U,16)_",0)"),U)
+39 SET BWNODE=BWNODE_" ("_$PIECE(@(P_$PIECE(Y,U,16)_",0)"),U,2)_")"
End DoDot:3
QUIT
+40 ;
+41 ;---> V RADIOLOGY PTR.
+42 IF X=9000010.22
Begin DoDot:3
+43 IF '$PIECE(Y,U,17)
SET BWNODE=BWNODE_U_"POINTER VALUE NOT SELECTED"
QUIT
+44 SET P=P_$PIECE(Y,U,17)_",0)"
IF '$DATA(@P)
Begin DoDot:4
+45 SET BWNODE=BWNODE_U_"POINTED TO ENTRY DOES NOT EXIST"
End DoDot:4
QUIT
+46 SET BWNODE=BWNODE_U_$EXTRACT($PIECE(@(P),U),1,24)
+47 SET BWNODE=BWNODE_" ("_$PIECE(@(P),U,9)_")"
End DoDot:3
QUIT
+48 ;---> V CPT PTR
+49 IF X=9000010.18
Begin DoDot:3
+50 IF '$PIECE(Y,U,8)
SET BWNODE=BWNODE_U_"POINTER VALUE NOT SELECTED"
QUIT
+51 SET P=P_$PIECE(Y,U,8)_",0)"
IF '$DATA(@P)
Begin DoDot:4
+52 SET BWNODE=BWNODE_U_"POINTED TO ENTRY DOES NOT EXIST"
End DoDot:4
QUIT
+53 SET BWNODE=BWNODE_U_$EXTRACT($PIECE(@(P),U,2),1,24)
+54 SET BWNODE=BWNODE_" ("_$PIECE(@(P),U)_")"
QUIT
End DoDot:3
QUIT
+55 ;
+56 ;---> NOTHING.
+57 SET BWNODE=BWNODE_U
End DoDot:2
+58 ;
+59 IF (X&(Z))
SET BWNODE=BWNODE_U_$EXTRACT($PIECE(^DIC(Z,0),U),1,15)
+60 ;
+61 DO FORMAT(.BWNODE)
+62 SET ^TMP("BW",$JOB,I,0)=BWNODE
End DoDot:1
+63 QUIT
+64 ;
FORMAT(Y) ;EP
+1 ;---> INSERT NECESSARY SPACING FOR COLUMNS.
+2 NEW A,B,C
+3 SET A=$PIECE(Y,U)
SET B=$PIECE(Y,U,2)
SET C=$PIECE(Y,U,3)
+4 SET Y=" "_A_$$S(26-$LENGTH(A))_B_$$S(35-$LENGTH(B))_C
+5 QUIT
+6 ;
S(S) ;EP
+1 ;---> SPACES.
+2 QUIT $$S^BWUTL7($GET(S))
+3 ;
EXIT ;EP
+1 DO KILLALL^BWUTL8
+2 QUIT
