Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: BWPROC

BWPROC.m

Go to the documentation of this file. 
  1. BWPROC ;IHS/ANMC/MWR/CIA - BW ADD/EDIT BW PROCEDURE;23-Jan-2009 10:35;DU
  1.  ;;2.0;WOMEN'S HEALTH;**8,9,11,12,13**;APR 19, 1996;Build 9
  1.  ;;* MICHAEL REMILLARD, DDS * ALASKA NATIVE MEDICAL CENTER *
  1.  ;;  CALLED BY VARIOUS OPTIONS TO ADD/EDIT PROCEDURES.
  1.  ;
  1.  ;
  1. ADDNEW ;EP
  1.  ;---> CALLED BY OPTION: "BW ADD A NEW PROCEDURE".
  1.  D SETVARS^BWUTL5 S BWPOP1=0
  1.  N DA,DIC,DIE,Y
  1.  F  D  Q:BWPOP1
  1.  .D NEW
  1.  .Q:BWPOP
  1.  .Q:'$G(DA)
  1.  .D EDIT2^BWPROC1(DA,.BWPOP)
  1.  .Q:BWPOP
  1.  .D FOLLOWUP^BWPROC1(DA)
  1.  D EXIT
  1.  Q
  1.  ;
  1. EXIT ;EP
  1.  D KILLALL^BWUTL8
  1.  Q
  1.  ;
  1.  ;
  1. NEW ;EP
  1.  ;---> SELECT A PATIENT.
  1.  D SETVARS^BWUTL5 K DIC
  1.  D TITLE^BWUTL5("ADD A NEW PROCEDURE")
  1. NEWNT ;EP
  1.  ;---> ENTER NEW WITHOUT A TITLE (ALLOWS OTHER TITLES, E.G., HISTORICAL)
  1.  ;---> LOOKUP AND SELECT PATIENT FROM BW PATIENT FILE.
  1.  D PATLKUP^BWUTL8(.Y,"ADD")
  1.  I Y<0 S (BWPOP,BWPOP1)=1 Q
  1.  S BWDFN=+Y
  1.  ;
  1. NEW1 ;EP
  1.  ;---> ADD A NEW PROCEDURE.
  1.  ;---> PATIENT SELECTED ALREADY BUT NOT PROCEDURE.
  1.  ;---> REQUIRED VARIABLE: BWDFN
  1.  ;
  1.  ;---> NOW SELECT PROCEDURE TYPE FROM BW PROCEDURE TYPE FILE.
  1.  N A,BWPCDN,S
  1.  S A="   Select PROCEDURE: "
  1.  ;---> SCREEN: ACTIVE FIELD CAN BE "YES" OR NULL, BUT NOT "NO".
  1.  ; Wise Woman and Mammography Project procedures are not available using this function.
  1.  S S="I (Y'=39&(Y'=44))&($P($G(^BWSITE(DUZ(2),Y)),U)'=0)"
  1.  D DIC^BWFMAN(9002086.2,"QEMA",.Y,A,"",S,"",.BWPOP)
  1.  Q:Y<0
  1.  ;---> BWPCDN=IEN OF PROCEDURE TYPE, FILE 9002086.2.
  1.  S BWPCDN=+Y
  1.  ;
  1.  ;---> IF IT'S A UNILATERAL MAMMOGRAM, PROMPT FOR LEFT OR RIGHT.
  1.  S BWLFRT=""
  1.  I BWPCDN=26 D  I $D(DIRUT) S BWPOP=1 Q
  1.  .N DIR
  1.  .S DIR("?")="   Select LEFT or RIGHT for this Unilateral Mammogram."
  1.  .S DIR(0)="SAM^l:LEFT;r:RIGHT",DIR("A")="   LEFT OR RIGHT: "
  1.  .D ^DIR K DIR
  1.  .Q:$D(DIRUT)
  1.  .S BWLFRT=Y
  1.  ;
  1.  ; If procedure is a Colposcopy (BX or Impression), or HPV Screen prompt for PAP that initiated it.
  1.  S BWPPAP=""
  1.  I BWPCDN=2!(BWPCDN=37)!(BWPCDN=40) D  Q:BWPOP
  1.  .W !!?3,"Select the PAP Smear that initiated this "_$S(BWPCDN=40:"HPV Screening.",1:"Colposcopy.")
  1.  .N A,S
  1.  .S DIC("?",1)="If a previous abnormal PAP Smear was the reason for"
  1.  .S DIC("?")="this Colposcopy or HPV Screening, enter the Accession# of that PAP here."
  1.  .S A="   PAP Smear: ",S="D PAPSCRN^BWUTL2"
  1.  .D DIC^BWFMAN(9002086.1,"QEMA",.Y,A,"",S,"",.BWPOP)
  1.  .Q:Y<0
  1.  .;---> BWPPAP=IEN OF PREVIOUS PAP IN BW PROCEDURE FILE 9002086.1.
  1.  .S BWPPAP=+Y
  1.  ;
  1.  ;---> ASK DATE, CHECK FOR DUPLICATE PROCEDURE ON SAME DATE.
  1.  D DATECHK Q:BWPOP
  1.  D NEW2(BWDFN,BWPCDN,BWPCDT,"",BWPPAP,.DA,.BWERROR)
  1.  Q
  1.  ;
  1. NEW2(DFN,PCDIEN,DATE,DRSTRG,PREVPAP,DA,ERROR) ;EP
  1.  ;---> ADD A NEW PROCEDURE.
  1.  ;---> PATIENT AND PROCEDURE ALREADY SELECTED.
  1.  ;---> NOW GENERATE ACCESSION# FOR BW PROCEDURE FILE ENTRY.
  1.  ;---> REQUIRED VARIABLES: DFN=IEN IN BW PATIENT FILE
  1.  ;--->                     PCDIEN=IEN OF PROCEDURE TYPE (#9002086.2).
  1.  ;
  1.  S X=$$ACCSSN^BWUTL5(PCDIEN) N DIC
  1.  I X']"" D  Q
  1.  .W !!?5,*7,"UNABLE TO GENERATE ACCESSION#. CONTACT YOUR SITE MANAGER."
  1.  .S ERROR=-1 D DIRZ^BWUTL3
  1.  ;
  1.  I $G(DRSTRG)']"" D
  1.  .;---> DEFAULTS: DATE OF PROCURE IS TODAY, STATUS IS OPEN.
  1.  .S DRSTRG=".02////"_DFN_";.04////"_PCDIEN
  1.  .S DRSTRG=DRSTRG_";.09///"_$S($D(BWLFRT):BWLFRT,1:"")_";.12///"_DATE
  1.  .;---> NEXT LINE FLAGS THIS PROCEDURE FOR CDC EXPORT IF NECESSARY.
  1.  .;---> * !NOT CURRENTLY USED, SAVE IN CASE IMS SWITCHES BACK.
  1.  .;--->    FOR NOW THEY WANT ALL PROCEDURES EXPORTED EACH TIME.
  1.  .;S DRSTRG=DRSTRG_";.14///o;.17////"_$$CDCEXP^BWUTL5(PCDIEN,DUZ(2))
  1.  .S DRSTRG=DRSTRG_";.14///o"
  1.  .S DRSTRG=DRSTRG_";.18////"_DUZ_";.19///T;.3////"_$G(PREVPAP)
  1.  .S DRSTRG=DRSTRG_";.34////"_$G(DUZ(2))
  1.  .; Stuff default specimen type if procedure is a PAP Smear
  1.  .S:PCDIEN=1 DRSTRG=DRSTRG_";.302////"_$$PAPST(DATE)
  1.  ;
  1.  D FILE^BWFMAN(9002086.1,DRSTRG,"ML",X,9002086,.Y)
  1.  ;---> IF Y<0, CHECK PERMISSIONS.
  1.  I Y<0 D  Q
  1.  .S ERROR=Y W !?5,*7,"UNABLE TO CREATE NEW PROCEDURE."
  1.  .D DIRZ^BWUTL3 S BWPOP=1
  1.  S DA=+Y
  1.  Q
  1.  ;
  1.  ;
  1. EDIT ;EP
  1.  ;---> CALLED BY OPTION: "BW EDIT PROCEDURE".
  1.  ;---> EDIT AN EXISTING PROCEDURE.
  1.  D TITLE^BWUTL5("EDIT A PROCEDURE")
  1.  D LKUPPCD(.Y)
  1.  Q:Y<0
  1.  ;---> DA=IEN OF PROCEDURE IN PROCEDURE FILE 9002086.1.
  1.  S DA=+Y
  1.  D EDIT2^BWPROC1(DA,.BWPOP) Q:BWPOP!($D(BWNOFOL))
  1.  D FOLLOWUP^BWPROC1(DA)
  1.  D EXIT
  1.  Q
  1.  ;
  1.  ;
  1. HISTORIC ;EP
  1.  ;---> CALLED BY OPTION: "BW ADD AN HISTORICAL PROCEDURE".
  1.  ;---> ADD HISTORICAL PROCEDURES (NO PROVIDER, WARD/CLINIC, FACILITY).
  1.  D SETVARS^BWUTL5 S BWPOP1=0 N DA,DIE,Y
  1.  F  D  Q:BWPOP1
  1.  .D TITLE^BWUTL5("ENTER HISTORICAL DATA")
  1.  .D NEWNT W !
  1.  .Q:(BWPOP!('$G(DA)))
  1.  .S BWPN=$P(^BWPCD(DA,0),U,4)
  1.  .S DR=".05;.08;.1;.14////c"
  1.  .D DIE^BWFMAN(9002086.1,DR,DA,.BWPOP)
  1.  D EXIT
  1.  Q
  1.  ;
  1.  ;
  1. CDCUPDT(DA) ;EP
  1.  ;---> WHEN A RECORD IS EXPORTED, UPDATE CDC EXPORT DATE AND STATUS.
  1.  ;---> DA=IEN IN BW PROCEDURE FILE.
  1.  Q:'$G(DA)
  1.  ;---> * !!FLAG NOT CURRENLY DELETED.  RETAINED IN CASE IMS CHANGES.
  1.  ;S DR=".16////"_DT_";.17////@"
  1.  S DR=".16////"_DT
  1.  D DIE^BWFMAN(9002086.1,DR,DA)
  1.  Q
  1.  ;
  1.  ;
  1. LABEDIT ;EP
  1.  ;---> CALLED BY OPTION: "BW LAB EDIT PROCEDURE".
  1.  S BWNOFOL=1 D EDIT,EXIT
  1.  Q
  1.  ;
  1.  ;
  1. ADDCBE(DFN,BWPAPDA) ;EP
  1.  ;---> ADD CBE (CLINICAL BREAST EXAM), FROM PROCEDURE FOLLOW-UP MENU.
  1.  ;---> REQUIRED VARIABLE: DFN=IEN IN BW PATIENT FILE.
  1.  ;---> NOTE: PROCEDURE TYPE CBE HAS IEN=27 IN ^BWPN (#9002086.2).
  1.  N BWPCDN,BWPCDT,BWTITLE,DA
  1.  S BWPCDN=27
  1.  W !!?3,"Enter the date on which this Breast Exam was performed."
  1.  D DATECHK Q:BWPOP
  1.  D NEW2(DFN,27,BWPCDT,"","",.DA,.BWERROR)
  1.  Q:$G(BWERROR)<0  D EDIT2^BWPROC1(DA)
  1.  ;
  1.  ;---> THE REMAINDER OF THIS CALL IS PURELY FOR CDC PURPOSES.
  1.  ;---> AT THE REQUEST OF CDC/IMS, CBE'S ADDED FROM THE PROCEDURE
  1.  ;---> FOLLOW-UP MENU FOR A PAP, SHOULD BE STORED (AND EXPORTED) WITH
  1.  ;---> THE PAP.
  1.  ;---> QUIT IF THE PROCEDURE WAS NOT A PAP.
  1.  Q:'+BWPAPDA  Q:$D(^BWPCD(BWPAPDA,0))
  1.  Q:$P(^BWPCD(BWPAPDA,0),U,4)'=1
  1.  ;---> QUIT IF NOT EXPORTING TO CDC.
  1.  Q:'$$CDC^BWUTL5(DUZ(2))
  1.  D ADDCBE1(DA,BWPAPDA)
  1.  ;---> STORE IEN OF PAP INTO WHICH THIS CBE WAS STUFFED.
  1.  D DIE^BWFMAN(9002086.1,"2.36////"_BWPAPDA,DA)
  1.  Q
  1.  ;
  1. ADDCBE1(BWCBEDA,BWPAPDA) ;EP
  1.  ;---> THIS CALL IS PURELY FOR CDC PURPOSES.
  1.  ;---> STORE RESULT AND DATE OF THIS CBE IN A PAP (IF THE CBE WAS
  1.  ;---> ENTERED FROM THE PROCEDURE FOLLOW-UP MENU FOR A PAP).
  1.  Q:'$G(BWCBEDA)  Q:'$G(BWPAPDA)
  1.  N BWDT,BWDX,DR,Y
  1.  ;---> SET Y=ZERO NODE OF THE CBE.
  1.  S Y=^BWPCD(BWCBEDA,0)
  1.  ;---> GET RESULT OF THIS CBE.
  1.  S BWDX=$P(Y,U,5),BWDT=$P(Y,U,12)
  1.  ;---> IF RESULT IS "ERROR/DISREGARD", DELETE CBE FIELDS IN PAP.
  1.  S:BWDX=8 (BWDT,BWDX)="@"
  1.  ;---> GET CDC EQUIVALENT CBE RESULT/DIAGNOSIS.
  1.  S BWDX=$S(BWDX:$P(^BWDIAG(BWDX,0),U,27),1:"@")
  1.  ;---> STUFF CBE RESULT AND DATE UNDER THIS PAP (PER IMS/CDC REQUEST).
  1.  S DR="2.32////"_BWDX_";2.33////"_BWDT
  1.  D DIE^BWFMAN(9002086.1,DR,BWPAPDA,"",1)
  1.  Q
  1.  ;
  1.  ;
  1. RADMOD(DA,MSG) ;EP
  1.  ;---> MODIFY A PROCEDURE THAT WAS IMPORTED FROM IHS RADIOLOGY AND
  1.  ;---> HAS BEEN CHANGED.
  1.  ;---> DA=IEN OF PROCEDURE IN BW PROCEDURE FILE #9002086.1.
  1.  ;---> MSG=MESSAGE TO BE ADDED TO CLINICAL HISTORY.
  1.  Q:'$G(DA)
  1.  S DR=".13////"_DT_";.14////o;3.01////"_$G(MSG)
  1.  D DIE^BWFMAN(9002086.1,DR,DA,.BWPOP)
  1.  Q
  1.  ;
  1.  ;
  1. LKUPPCD(Y) ;EP
  1.  ;---> LOOKUP A PROCEDURE.
  1.  N A,SCRN
  1.  D SETVARS^BWUTL5
  1.  S A="Select ACCESSION# or PATIENT NAME: "
  1.  S SCRN="I ""^39^44^""'[$P(^(0),U,4)"
  1.  D DIC^BWFMAN(9002086.1,"QEMA",.Y,A,"",SCRN,"",.BWPOP)
  1.  Q
  1.  ;
  1. DATECHK ;EP
  1.  ;---> PROMPT FOR DATE, CHECK FOR DUPLICATE PROCEDURE ON SAME DATE.
  1.  N BWNEW,DIR,DIRUT,N,Y S BWPOP=0
  1.  S DIR("?",1)="   Enter the date on which this procedure was performed:"
  1.  S DIR("?")="   (NOTE: Dates in the future may NOT be entered.)"
  1.  S DIR(0)="DA^0:DT:EX",DIR("A")="   Select DATE:      ",DIR("B")="TODAY"
  1.  D ^DIR K DIR
  1.  I Y<1 S BWPOP=1 Q
  1.  S BWPCDT=Y D DD^%DT W "  ",Y
  1.  S N=0,BWNEW=0
  1.  F  S N=$O(^BWPCD("C",BWDFN,N)) Q:('N)!(BWPOP)!(BWNEW)  D
  1.  .S Y=^BWPCD(N,0)
  1.  .;---> QUIT IF NOT THE SAME PROCEDURE TYPE.
  1.  .Q:$P(Y,U,4)'=BWPCDN
  1.  .;---> QUIT IF NOT THE SAME PROCEDURE DATE.
  1.  .Q:$P(Y,U,12)'=BWPCDT
  1.  .;---> QUIT IF THIS PROCEDURE HAS A RESULT/DIAG OF "ERROR/DISREGARD".
  1.  .Q:$P(Y,U,5)=8
  1.  .N BWPN S BWPN=$P(^BWPN($P(Y,U,4),0),U)
  1.  .W !!?5,"A ",BWPN," already exists for this patient on this date,"
  1.  .W !?5,"with an Accession# of ",$P(Y,U)
  1.  .W ".  You may edit that procedure by"
  1.  .W !?5,"calling up ",$P(Y,U)," under the ""Edit a Procedure"" option."
  1.  .W !?5,"Or you may enter another ",BWPN," for this patient"
  1.  .W !?5,"on this date."
  1.  .W !!?5,"Do you REALLY want to add another ",BWPN," for this patient"
  1.  .W !?5,"on this date?"
  1.  .S DIR("?")="       Enter NO to avoid adding another "_BWPN
  1.  .S DIR("?")=DIR("?")_" on this date."
  1.  .S DIR(0)="Y",DIR("A")="     Enter Yes or No",DIR("B")="NO"
  1.  .D ^DIR K DIR
  1.  .I $D(DIRUT)!('Y) S BWPOP=1 Q
  1.  .S BWNEW=1
  1.  Q
  1.  ;
  1. ERROR1 ;EP
  1.  W !!?10,*7,"NEW PROCEDURE ENTRY FOR THIS PATIENT FAILED."
  1.  Q
  1.  ; Return Specimen Type for default
  1. PAPST(DATE) ;
  1.  N DEF,BTSDT
  1.  S DEF=$$GET1^DIQ(9002086.02,$G(DUZ(2)),.24,"I")
  1.  S BTSDT=+$$GET1^DIQ(9002086.02,$G(DUZ(2)),.52,"I")
  1.  Q:'BTSDT ""
  1.  Q $S(DATE>$$FMADD^XLFDT(BTSDT,-1):DEF,1:"")