- 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
