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

PXRMLPOE.m

Go to the documentation of this file.
  1. PXRMLPOE ;SLC/PJH,PKR - Build OE/RR Team from Patient List ;02/21/2014
  1. ;;2.0;CLINICAL REMINDERS;**4,24,26**;Feb 04, 2005;Build 404
  1. ;
  1. ; Called from PXRM PATIENT LIST OE/RR protocol
  1. ASK(PLIEN,OPT) ;Verify patient list name
  1. N DIR,X,Y,TEXT
  1. K DIROUT,DIRUT,DTOUT,DUOUT
  1. S DIR(0)="YA0"
  1. S DIR("A")=OPT_" patient list "_$P($G(^PXRMXP(810.5,PLIEN,0)),U)_"?: "
  1. S DIR("B")="N"
  1. S DIR("?")="Enter Y or N. For detailed help type ??"
  1. W !
  1. D ^DIR K DIR
  1. I $D(DIROUT) S DTOUT=1
  1. I $D(DTOUT)!($D(DUOUT)) Q
  1. I $E(Y(0))="N" S DUOUT=1 Q
  1. Q
  1. ;
  1. LOCK(LIST) ;Lock the list
  1. L +^PXRMXP(100.21,LIST):DILOCKTM
  1. E W !!?5,"Another user is using this OE/RR team list" S DUOUT=1
  1. Q
  1. ;
  1. OERR(IENO) ;Copy patient list to OE/RR Team
  1. ;Check if OK to copy
  1. D ASK(IENO,"Copy") Q:$D(DUOUT)!$D(DTOUT)
  1. ;
  1. N IENN,NNAME,ONAME,TEXT,X,Y
  1. ;
  1. ;Select OE/RR Team to copy to
  1. S TEXT="Select OE/RR TEAM name to copy to: "
  1. D OTEAM(.IENN,.NNAME,TEXT) Q:$D(DUOUT)!$D(DTOUT) Q:'IENN
  1. ;
  1. S ONAME=$P($G(^PXRMXP(810.5,IENO,0)),U)
  1. ;
  1. ;Update OE/RR Team list
  1. D UPDLST(IENO,IENN,NNAME)
  1. Q
  1. ;
  1. OK ;Option to overwrite existing list
  1. N X,Y,TEXT
  1. K DIROUT,DIRUT,DTOUT,DUOUT
  1. S DIR(0)="YA0"
  1. S DIR("A")="Overwrite existing OE/RR Team list: "
  1. S DIR("B")="N"
  1. S DIR("?")="Enter Y or N. For detailed help type ??"
  1. S DIR("??")=U_"D HELP^PXRMLCR(1)"
  1. W !
  1. D ^DIR K DIR
  1. I $D(DIROUT) S DTOUT=1
  1. I $D(DTOUT)!($D(DUOUT)) Q
  1. I $E(Y(0))="N" S DUOUT=1 Q
  1. Q
  1. ;
  1. OTEAM(LIST,NAME,TEXT) ;Select OERR/Team
  1. N X,Y,DIC,DIE,DR,DLAYGO
  1. W !
  1. W !,"To overwrite an existing list you must be the creator of the list and"
  1. W !,"the OE/RR team list must be defined as a Team List."
  1. OT1 S DIC=100.21,DLAYGO=DIC,DIC(0)="QAEMZL"
  1. S DIC("S")="I $P($G(^(0)),U,2)=""TM"",$P($G(^(0)),U,5)=DUZ"
  1. S DIC("A")=TEXT
  1. W !
  1. D ^DIC
  1. I X="" W !,"An OE/RR Team name must be entered" G OT1
  1. I X=(U_U) S DTOUT=1
  1. I Y=-1 S DUOUT=1
  1. I $D(DTOUT)!$D(DUOUT) Q
  1. ;
  1. ;Check if OK to overwrite
  1. I $P(Y,U,3)'=1 D Q:$D(DTOUT) G:$D(DUOUT) OT1
  1. .D OK
  1. ;Return list ien
  1. S LIST=$P(Y,U),NAME=$P(Y,U,2)
  1. Q
  1. ;
  1. UPDLST(IENO,LIST,NAME) ;Update patient list
  1. N CNT,DA,DFN,DIK,DUOUT,FDA,FDAIEN,IEN,MSG,SUB,TEMP
  1. ;Lock patient list
  1. D LOCK(LIST) Q:$D(DUOUT)
  1. ;
  1. ;Clear existing list
  1. S SUB=0
  1. F S SUB=$O(^OR(100.21,LIST,10,SUB)) Q:'SUB D
  1. . S DA=SUB,DA(1)=LIST,DIK="^OR(100.21,"_DA(1)_",10,"
  1. . D ^DIK
  1. ;
  1. ;DBIA #4561 covers putting data into OE/RR list.
  1. ;Create the stub in file #100.21
  1. W !,"Updating "_NAME
  1. S FDA(100.21,"?1,",.01)=NAME
  1. S FDA(100.21,"?1,",.1)=$$UP^XLFSTR(NAME)
  1. S FDA(100.21,"?1,",1)="TM"
  1. S FDA(100.21,"?1,",1.6)=DUZ
  1. S FDA(100.21,"?1,",1.65)=$$NOW^XLFDT
  1. S FDA(100.21,"?1,",11)="0"
  1. D UPDATE^DIE("","FDA","FDAIEN","MSG")
  1. ;Error
  1. I $D(MSG) D Q
  1. . N TEXT
  1. . S TEXT(1)="The patient list copy failed."
  1. . S TEXT(2)="Examine the following error message for the reason."
  1. . S TEXT(3)=""
  1. . D MES^XPDUTL(.TEXT)
  1. . D AWRITE^PXRMUTIL("MSG")
  1. . W ! H 3
  1. . D UNLOCK(LIST)
  1. ;Do a direct copy of the patients.
  1. S (CNT,SUB)=0,IEN=FDAIEN(1)
  1. F S SUB=$O(^PXRMXP(810.5,IENO,30,SUB)) Q:'SUB D
  1. . S DFN=$P($G(^PXRMXP(810.5,IENO,30,SUB,0)),U,1) Q:'DFN
  1. . S CNT=CNT+1
  1. . S TEMP=DFN_";DPT("
  1. . S ^OR(100.21,IEN,10,CNT,0)=TEMP
  1. . S ^OR(100.21,IEN,10,"B",TEMP,CNT)=""
  1. . S ^OR(100.21,"AB",TEMP,IEN,CNT)=""
  1. S ^OR(100.21,IEN,10,0)="^100.2101AV"_U_CNT_U_CNT
  1. ;Unlock patient list
  1. D UNLOCK(LIST)
  1. W !!,"Completed copy of patient list '"_ONAME_"'"
  1. W !,"into OE/RR Team '"_NNAME_"'",! H 3
  1. Q
  1. ;
  1. UNLOCK(LIST) ;Unlock the list
  1. L -^PXRMXP(100.21,LIST)
  1. Q
  1. ;