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

WVPROC.m

Go to the documentation of this file.
  1. WVPROC ;HCIOFO/FT,JR - WV ADD/EDIT WV PROCEDURE; ;5/10/99 10:22
  1. ;;1.0;WOMEN'S HEALTH;**3,6**;Sep 30, 1998
  1. ;; Original routine created by IHS/ANMC/MWR
  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: "WV ADD A NEW PROCEDURE".
  1. D SETVARS^WVUTL5 S WVPOP1=0
  1. N DA,DIC,DIE,Y
  1. F D Q:WVPOP1
  1. .D NEW
  1. .Q:WVPOP
  1. .D EDIT2^WVPROC1(DA,.WVPOP)
  1. .Q:WVPOP
  1. .D PCDVARS^WVUTL3(DA,1)
  1. .D NORMAL^WVPROC1
  1. D EXIT
  1. Q
  1. ;
  1. EXIT ;EP
  1. D KILLALL^WVUTL8
  1. Q
  1. ;
  1. ;
  1. NEW ;EP
  1. ;---> SELECT A PATIENT.
  1. D SETVARS^WVUTL5 K DIC
  1. D TITLE^WVUTL5("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 WV PATIENT FILE.
  1. ; Quit if no default case manager
  1. I '$$DCM^WVUTL9(DUZ(2)) D NODCM^WVUTL9 S (WVPOP,WVPOP1)=1 Q
  1. D PATLKUP^WVUTL8(.Y,"ADD")
  1. I Y<0 S (WVPOP,WVPOP1)=1 Q
  1. S WVDFN=+Y
  1. ;
  1. NEW1 ;EP
  1. ;---> ADD A NEW PROCEDURE.
  1. ;---> PATIENT SELECTED ALREADY BUT NOT PROCEDURE.
  1. ;---> REQUIRED VARIABLE: WVDFN
  1. ;
  1. ;---> NOW SELECT PROCEDURE TYPE FROM WV PROCEDURE TYPE FILE.
  1. N A,WVPCDN,S
  1. S A=" Select PROCEDURE: "
  1. ;---> SCREEN: ACTIVE FIELD CAN BE "YES" OR NULL, BUT NOT "NO".
  1. S S="I $P($G(^WV(790.02,DUZ(2),Y)),U)'=0"
  1. D DIC^WVFMAN(790.2,"QEMA",.Y,A,"PAP SMEAR",S,"",.WVPOP)
  1. Q:Y<0
  1. ;---> WVPCDN=IEN OF PROCEDURE TYPE, FILE 790.2.
  1. S WVPCDN=+Y
  1. ;
  1. ;---> IF IT'S A UNILATERAL MAMMOGRAM, PROMPT FOR LEFT OR RIGHT.
  1. S WVLFRT=""
  1. I WVPCDN=26 D I $D(DIRUT) S WVPOP=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 WVLFRT=Y
  1. ;
  1. ;---> IF IT'S A COLPOSCOPY, PROMPT FOR PAP THAT INITIATED IT.
  1. S WVPPAP=""
  1. I WVPCDN=2 D Q:WVPOP
  1. .W !!?3,"Select the PAP Smear that initiated this Colposcopy."
  1. .N A,S
  1. .S DIC("?",1)="If a previous abnormal PAP Smear was the reason for"
  1. .S DIC("?")="this Colposcopy, enter the Accession# of that PAP here."
  1. .S A=" PAP Smear: ",S="D PAPSCRN^WVUTL2"
  1. .D DIC^WVFMAN(790.1,"QEMA",.Y,A,"",S,"",.WVPOP)
  1. .Q:Y<0
  1. .;---> WVPPAP=IEN OF PREVIOUS PAP IN WV PROCEDURE FILE 790.1.
  1. .S WVPPAP=+Y
  1. ;
  1. ;---> ASK DATE, CHECK FOR DUPLICATE PROCEDURE ON SAME DATE.
  1. D DATECHK Q:WVPOP
  1. D NEW2(WVDFN,WVPCDN,WVPCDT,"",WVPPAP,.DA,.WVERROR)
  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 WV PROCEDURE FILE ENTRY.
  1. ;---> REQUIRED VARIABLES: DFN=IEN IN WV PATIENT FILE
  1. ;---> PCDIEN=IEN OF PROCEDURE TYPE (#790.2).
  1. ;
  1. S X=$$ACCSSN^WVUTL5(PCDIEN) N DIC
  1. I X']"" D Q
  1. .S ERROR=-1
  1. .Q:$D(ZTQUEUED) ;quit if a background (tasked) job
  1. .W !!?5,*7,"UNABLE TO GENERATE ACCESSION#. CONTACT YOUR SITE MANAGER."
  1. .D DIRZ^WVUTL3
  1. .Q
  1. ;
  1. I $G(DRSTRG)']"" D
  1. .;---> DEFAULTS: DATE OF PROCEDURE IS TODAY, STATUS IS OPEN.
  1. .S DRSTRG=".02////"_DFN_";.04////"_PCDIEN
  1. .S DRSTRG=DRSTRG_";.09///"_$S($D(WVLFRT):WVLFRT,1:"")_";.12///"_DATE
  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. ;
  1. D FILE^WVFMAN(790.1,DRSTRG,"ML",X,790,.Y)
  1. ;---> IF Y<0, CHECK PERMISSIONS.
  1. I Y<0 D Q
  1. .S ERROR=Y
  1. .Q:$D(ZTQUEUED) ;quit if a background (tasked) job
  1. .W !?5,*7,"UNABLE TO CREATE NEW PROCEDURE."
  1. .D DIRZ^WVUTL3 S WVPOP=1
  1. .Q
  1. S DA=+Y
  1. Q
  1. ;
  1. ;
  1. EDIT ;EP
  1. ;---> CALLED BY OPTION: "WV EDIT PROCEDURE".
  1. ;---> EDIT AN EXISTING PROCEDURE.
  1. D TITLE^WVUTL5("EDIT A PROCEDURE")
  1. D LKUPPCD(.Y)
  1. Q:Y<0
  1. LT ; Called from WVLABADD routine to immediately edit a procedure created
  1. ; from a lab test.
  1. ;---> DA=IEN OF PROCEDURE IN PROCEDURE FILE 790.1.
  1. S DA=+Y
  1. I $P($G(^WV(790.1,+DA,0)),U,15)]"" D ^WVRADWP
  1. I $P($G(^WV(790.1,+DA,2)),U,17)]"" D
  1. .D ^WVLABWP
  1. .Q:'$D(^TMP("WVLAB",$J))
  1. .S WVLOOP=0
  1. .F S WVLOOP=$O(^TMP("WVLAB",$J,WVLOOP)) Q:WVLOOP'>0 D
  1. ..S ^WV(790.1,DA,9,WVLOOP,0)=$G(^TMP("WVLAB",$J,WVLOOP,0)) S WVLOOP(1)=WVLOOP
  1. ..Q
  1. .S ^WV(790.1,DA,9,0)="^^"_$G(WVLOOP(1))_"^"_$G(WVLOOP(1))
  1. .K ^TMP("WVLAB",$J)
  1. .Q
  1. D EDIT2^WVPROC1(DA,.WVPOP) Q:WVPOP!($D(WVNOFOL))
  1. D EX^WVRADWP
  1. D PCDVARS^WVUTL3(DA,1)
  1. D NORMAL^WVPROC1
  1. D EXIT
  1. Q
  1. ;
  1. ;
  1. HISTORIC ;EP
  1. ;---> CALLED BY OPTION: "WV ADD AN HISTORICAL PROCEDURE".
  1. ;---> ADD HISTORICAL PROCEDURES (NO PROVIDER, WARD/CLINIC, FACILITY).
  1. D SETVARS^WVUTL5 S WVPOP1=0 N DA,DIE,Y
  1. F D Q:WVPOP1
  1. .D TITLE^WVUTL5("ENTER HISTORICAL DATA")
  1. .D NEWNT W !
  1. .Q:(WVPOP!('$G(DA)))
  1. .S WVPN=$P(^WV(790.1,DA,0),U,4)
  1. .S DR=".05;.08;.1;.14////c"
  1. .D DIE^WVFMAN(790.1,DR,DA,.WVPOP)
  1. D EXIT
  1. Q
  1. ;
  1. ;
  1. LABEDIT ;EP
  1. ;---> CALLED BY OPTION: "WV LAB EDIT PROCEDURE".
  1. S WVNOFOL=1 D EDIT,EXIT
  1. Q
  1. ;
  1. ;
  1. RADMOD(DA) ;EP
  1. ;---> MODIFY A PROCEDURE THAT WAS IMPORTED FROM RADIOLOGY AND
  1. ;---> HAS BEEN CHANGED.
  1. ;---> DA=IEN OF PROCEDURE IN WV PROCEDURE FILE #790.1.
  1. Q:'$G(DA)
  1. S DR=".13////"_DT_";.14////o"
  1. D DIE^WVFMAN(790.1,DR,DA,.WVPOP)
  1. Q
  1. ;
  1. ;
  1. LKUPPCD(Y) ;EP
  1. ;---> LOOKUP A PROCEDURE.
  1. N A
  1. D SETVARS^WVUTL5
  1. S A="Select ACCESSION# or PATIENT NAME: "
  1. D DIC^WVFMAN(790.1,"QEMA",.Y,A,"","","",.WVPOP)
  1. Q
  1. ;
  1. DATECHK ;EP
  1. ;---> PROMPT FOR DATE, CHECK FOR DUPLICATE PROCEDURE ON SAME DATE.
  1. N WVNEW,DIR,DIRUT,N,Y S WVPOP=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 WVPOP=1 Q
  1. S WVPCDT=Y D DD^%DT W " ",Y
  1. S N=0,WVNEW=0
  1. F S N=$O(^WV(790.1,"C",WVDFN,N)) Q:('N)!(WVPOP)!(WVNEW) D
  1. .S Y=^WV(790.1,N,0)
  1. .;---> QUIT IF NOT THE SAME PROCEDURE TYPE.
  1. .Q:$P(Y,U,4)'=WVPCDN
  1. .;---> QUIT IF NOT THE SAME PROCEDURE DATE.
  1. .Q:$P(Y,U,12)'=WVPCDT
  1. .;---> QUIT IF THIS PROCEDURE HAS A RESULT/DIAG OF "ERROR/DISREGARD".
  1. .Q:$P(Y,U,5)=8
  1. .N WVPN S WVPN=$P(^WV(790.2,$P(Y,U,4),0),U)
  1. .W !!?5,"A ",WVPN," 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 ",WVPN," for this patient"
  1. .W !?5,"on this date."
  1. .W !!?5,"Do you REALLY want to add another ",WVPN," for this patient"
  1. .W !?5,"on this date?"
  1. .S DIR("?")=" Enter NO to avoid adding another "_WVPN
  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 WVPOP=1 Q
  1. .S WVNEW=1
  1. Q
  1. ;
  1. ERROR1 ;EP
  1. W !!?10,*7,"NEW PROCEDURE ENTRY FOR THIS PATIENT FAILED."
  1. Q