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

VENPCCC1.m

Go to the documentation of this file. 
  1. VENPCCC1 ; IHS/OIT/GIS - CHECK LIST EDITING AND VIEWING ;
  1.  ;;2.6;PCC+;;NOV 12, 2007
  1.  ;
  1.  ;
  1.  ;
  1. AIC ; EP-ATTACH AN ITEM TO A CHECKLIST
  1.  N IIEN,DIC,LIEN,DA,X,Y
  1.  W !,"Select an ITEM to assign to a checklist ->"
  1.  S IIEN=$$SI I 'IIEN Q
  1.  D ATI(IIEN)
  1.  S DIC="^VEN(7.9,",DIC(0)="AEQL",DLAYGO=19707.9
  1.  S DIC("A")="Select a CHECKLIST: "
  1.  D ^DIC I Y=-1 Q
  1.  S LIEN=+Y
  1.  I $D(^VEN(7.91,IIEN,2,"B",LIEN)) W !,"This item is already in this checklist.  Try again..." Q
  1.  S DA(1)=IIEN S DIC="^VEN(7.91,"_DA(1)_",2,"
  1.  S DIC("P")="19707.912P" S DIC(0)="L",DLAYGO=19707.912
  1.  S X="`"_LIEN
  1.  D ^DIC
  1.  W !,"OK, this item will now appear on the checklist!"
  1.  D ^XBFMK
  1.  Q
  1.  ;
  1. DIC ; EP-DELETE AN ITEM FROM A CHECKLIST
  1.  N DIK,DA,X,Y,%,IIEN,DICS,LIEN,STG,CNT,ARR,CNAME,PCE,CKIEN
  1.  W !,"Select the ITEM to be deleted ->"
  1.  N %
  1.  S %=$$SI I '% Q
  1.  D AT(%)
  1.  S IIEN=% S STG="" S LIEN=0
  1.  F  S LIEN=$O(^VEN(7.91,IIEN,2,"B",LIEN)) Q:'LIEN  S STG=STG_LIEN_"|"_$O(^VEN(7.91,IIEN,2,"B",LIEN,0))_U
  1.  I '$L(STG) W !,"This item is not currently assigned to any checklists!" Q
  1.  I $L(STG,U)=2 D  Q  ; IF THERE IS ONLY ONE CHECKLIST
  1.  . S %=$P(STG,U) I '$L(%) Q
  1.  . S LIEN=+% I 'LIEN Q
  1.  . S CKIEN=$P(%,"|",2) I 'CKIEN Q
  1.  . S CNAME=$P($G(^VEN(7.9,LIEN,0)),U) I '$L(CNAME) Q
  1.  . W !,"This item is currently assigned to the "_CNAME_" checklist",!,"Sure you want to delete it"
  1.  . S %="" D YN^DICN I %'=1 Q
  1.  . S DA=$O(^VEN(7.91,IIEN,2,"B",LIEN,0)) I 'DA Q  ; PATCHED BY GIS/OIT 1/15/06 ; PCC+ 2.5 PATCH 2
  1.  . D DICD
  1.  . Q
  1.  W !,"This item is currently assigned to the following checklists ->" ; MULTIPLE CHECKLISTS
  1.  S CNT=0
  1.  F PCE=1:1:($L(STG,U)-1) S %=$P(STG,U,PCE) I $L(%) D
  1.  . S LIEN=+% I 'LIEN Q
  1.  . S CKIEN=$P(%,"|",2) I 'CKIEN Q
  1.  . S CNAME=$P($G(^VEN(7.9,LIEN,0)),U) I '$L(CNAME) Q
  1.  . S CNT=CNT+1
  1.  . S ARR(CNT)=CKIEN
  1.  . W !?3,CNT,?6,CNAME
  1.  . Q
  1.  S DIR("A")="The item will be deleted from which checklist"
  1.  S DIR(0)="N^1:"_CNT_":0" D ^DIR
  1.  I $G(DUOUT)!($G(DTOUT)) G DICX
  1.  I 'Y G DICX
  1.  S DA=$G(ARR(Y)) I 'DA G DICX
  1. DICD S DA(1)=IIEN S DIK="^VEN(7.91,"_DA(1)_",2," ; DELETE THE SUBFILE ENTRY
  1.  D ^DIK
  1.  W !,"OK, this item has been removed from the checklist..."
  1. DICX D ^XBFMK ; CLEANUP
  1.  Q
  1.  ;
  1. ACT ; EP-ASSIGN A CHECKLIST TO A TEMPLATE
  1.  W !,"Select a checklist to assign to a PCC+ template ->"
  1.  N LIEN,DA,DIC,X,Y,%,%Y
  1.  S LIEN=$$SC I 'LIEN Q
  1.  W ! D AT(LIEN,1)
  1.  W !
  1.  S DIC("A")="Assign this checklist to what PCC+ template: "
  1.  S DIC="^VEN(7.41,",DIC(0)="AEQL",DLAYGO=19707.41
  1.  D ^DIC I Y=-1 Q
  1.  I $D(^VEN(7.41,+Y,17,"B",LIEN)) W !,"This checklist is already on the template! Request cancelled..." D ^XBFMK Q
  1.  W !,"Are you sure" S %="" D YN^DICN I %'=1 Q
  1.  S DA(1)=+Y
  1.  S DIC="^VEN(7.41,"_DA(1)_",17,",DIC(0)="L"
  1.  S DIC("P")="19707.4117P",DLAYGO=19707.4117
  1.  S X="`"_LIEN
  1.  D ^DIC I Y=-1 Q
  1.  D ^XBFMK
  1.  W !,"OK, this checklist will now appear on the template!"
  1.  Q
  1.  ; 
  1. DCT ; EP-DELETE A CHECKLIST FROM A PCC+ TEMPLATE
  1.  N DIC,X,Y,DA,CNAME,CKIEN,LIEN,TNAME
  1.  S DIC("A")="PCC+ Template: "
  1.  S DIC="^VEN(7.41,",DIC(0)="AEQM"
  1.  D ^DIC I Y=-1 G DCTX
  1.  S DA(1)=+Y S TNAME=$P(Y,U,2)
  1.  S DIC="^VEN(7.41,"_DA(1)_",17,",DIC(0)="AEQM"
  1.  S DIC("A")="Which CHECKLIST do you want to delete: "
  1.  D ^DIC I Y=-1 G DCTX
  1.  S CKIEN=+Y I 'CKIEN Q
  1.  S LIEN=$P($G(^VEN(7.41,DA(1),17,CKIEN,0)),U) I 'LIEN Q
  1.  S CNAME=$P($G(^VEN(7.9,LIEN,0)),U)
  1.  W !!,"The ",CNAME," checklist has been deleted from",!,"the ",TNAME," template..."
  1. DCTX D ^XBFMK
  1.  Q
  1.  ; 
  1. VI ; EP-VIEW AN ITEM
  1.  N %
  1.  S %=$$SI I '% Q
  1.  D ATI(%)
  1.  Q
  1.  ;
  1. VC ; EP-VIEW CHECLIST PROPERTIES
  1.  N %
  1.  S %=$$SC I '% Q
  1.  D AT(%,1)
  1.  Q
  1.  ;
  1. AC ; EP-ADD A CHECKLIST
  1.  N DA,DIR,DIC,DIE,DR,%,NAME,OGIEN,PMN,X,Y
  1. AC1 S DIR(0)="FO^1:25",DIR("A")="Name of new CHECKLIST"
  1.  D ^DIR
  1.  I X?1."^"!(X="") G ACFIN
  1.  I $G(DIRUT)!($G(DTOUT)) G ACFIN
  1.  I $D(^VEN(7.9,"B",X)) W !,"This name has already been used.  Try again..." G AC1
  1.  S NAME=X
  1.  S DIC="^VEN(7.98,",DIC(0)="AEQM",DIC("A")="Checklist content: "
  1.  D ^DIC I Y=-1 Q
  1.  S OGIEN=+Y
  1.  S PMN=$P($G(^VEN(7.98,OGIEN,0)),U,2) I '$L(PMN) Q
  1.  S %=(" ("_PMN_")") I NAME'[% S NAME=NAME_%
  1.  I $D(^VEN(7.9,"B",NAME)) W !,"The name '"_NAME_"' has already been used." W !,"Try again..." G AC1
  1.  S DIC="^VEN(7.9,",DIC(0)="L",DLAYGO=19707.9,X=NAME
  1.  D ^DIC I Y=-1 Q
  1.  S DIE=DIC,DA=+Y,DR=".02////^S X=OGIEN;.03;.04"
  1.  D ^DIE
  1.  W !,"OK, "_NAME_" has been added as a new checklist..."
  1. ACFIN D ^XBFMK
  1.  Q
  1.  ; 
  1. GCPT ; EP-GLOBAL EDIT OF CPT CODE
  1.  N DIR,DA,%,%Y,IIEN,C1,C2,X
  1.  S DIR(0)="F^1:9",DIR("A")="Change code from" S DIR("?")="Enter the CPT code to be changed."
  1.  D ^DIR
  1.  I $G(DUOUT)!$G(DTOUT) G GCPTX
  1.  I '$L(Y) G GCPTX
  1.  S FROM=Y
  1.  S DIR(0)="F^1:9",DIR("A")="Change code to" S DIR("?")="Enter the new CPT code."
  1.  D ^DIR
  1.  I $G(DUOUT)!$G(DTOUT) G GCPTX
  1.  I '$L(Y) G GCPTX
  1.  S TO=Y
  1.  W !,"Sure you want to change every instance of a CPT code from ",FROM," to ",TO
  1.  S %="" D YN^DICN
  1.  I %'=1 G GCPTX
  1.  S IIEN=0
  1.  F  S IIEN=$O(^VEN(7.91,IIEN)) Q:'IIEN  D  ; GLOBAL SUBSTITUTION
  1.  . S X=$G(^VEN(7.91,IIEN,0)) I '$L(X) Q
  1.  . S Y=0
  1.  . S C1=$P(X,U,7) I C1=FROM S $P(X,U,7)=TO,Y=1
  1.  . S C2=$P(X,U,8) I C2=FROM S $P(X,U,8)=TO,Y=1
  1.  . I 'Y Q
  1.  . S ^VEN(7.91,IIEN,0)=X
  1.  . W !,"The code for ",$P(X,U)," has been changed!"
  1.  . Q
  1. GCPTX D ^XBFMK
  1.  Q
  1.  ;
  1. AI ;EP- ADD AN ITEM
  1.  N DIC,DIE,DA,DR,X,Y
  1.  S DIC="^VEN(7.91," S DLAYGO=19707.91
  1.  S DIE=DIC S DIC(0)="AEQMLX"
  1.  S DIC("A")="Name of NEW ITEM: "
  1.  D ^DIC I Y=-1 Q
  1.  S DA=+Y
  1.  S DR=".03:.1"
  1.  D ^DIE
  1.  D ^XBFMK K DDER
  1.  Q
  1.  ;
  1. DI ; EP-DELETE AN ITEM
  1.  N IIEN,DIK,DA,%,%Y
  1.  W !!,"Select an item to DELETE ->"
  1.  S IIEN=$$IASK I 'IIEN Q
  1.  D ATI(IIEN)
  1.  W !!,"Are you sure you want to DELETE this item"
  1.  S %=""  D YN^DICN I %'=1 Q
  1.  S DIK="^VEN(7.91,",DA=IIEN
  1.  D ^DIK
  1.  D ^XBFMK
  1.  Q
  1.  ;
  1. EI ; EP-EDIT AN ITEM
  1.  N IIEN,DIE,DR,DA,X,Y
  1.  W !!,"Select an item to EDIT ->"
  1.  S IIEN=$$IASK I 'IIEN Q
  1.  D ATI(IIEN)
  1.  S DIE="^VEN(7.91,",DA=IIEN
  1.  S DR=".01;.03:.1"
  1.  D ^DIE
  1.  D ^XBFMK
  1.  Q
  1.  ;
  1. SC() ; EP-SELECT A CHECKLIST
  1.  N ARR,CNT,NAME,LIEN,OGIEN,MN,PCE,SEL,%
  1.  S CNT=0 S NAME=""
  1.  F  S NAME=$O(^VEN(7.9,"B",NAME)) Q:NAME=""  D
  1.  . S LIEN=$O(^VEN(7.9,"B",NAME,0)) I 'LIEN Q
  1.  . S %=$G(^VEN(7.9,LIEN,0)) I '$L(%) Q
  1.  . S OGIEN=$P(%,U,2) I 'OGIEN Q
  1.  . S PRE=$P(%,U,3) S POST=$P(%,U,4)
  1.  . S MN=$P($G(^VEN(7.98,OGIEN,0)),U,3) I MN="" Q
  1.  . S CNT=CNT+1
  1.  . S ARR(CNT)=CNT_"|0^"_NAME_"|4^"_MN_"|35^"_PRE_"|50^"_POST_"|60"
  1.  . S ARR(CNT,0)=LIEN
  1.  . Q
  1. CLIST W !!,$E($T(CHDR),8,999),!,$E($T(CSEP),8,999)
  1.  G LIST
  1.  ;
  1. IASK(DICS) ; EP - ASK FOR AN ITEM
  1.  N DIC,X,Y
  1.  I $L($G(DICS)) S DIC("S")=DICS
  1.  S DIC="^VEN(7.91,",DIC(0)="AEQM"
  1.  S DIC("A")="Checklist ITEM: "
  1.  D ^DIC I Y=-1 Q ""
  1.  Q +Y
  1.  ; 
  1. SI() ; EP - SELECT AN ITEM
  1.  N CNT,IIEN,X,Y,Z,%,NAME,GRP,CODE1,CODE2,PRE,POST,PCE,SEL,ARR,CFLG
  1.  S CNT=0,NAME="",CFLG=1
  1.  F  S NAME=$O(^VEN(7.91,"B",NAME)) Q:NAME=""  D  ; MAKE DISPLAAY ARRAY
  1.  . S IIEN=$O(^VEN(7.91,"B",NAME,0)) I 'IIEN Q
  1.  . S X=$G(^VEN(7.91,IIEN,0)) I '$L(X) Q
  1.  . S CNT=CNT+1
  1.  . S GRP=""
  1.  . I $P(X,U,3) S GRP=GRP_"I"
  1.  . I $P(X,U,4) S GRP=GRP_"C"
  1.  . I $P(X,U,5) S GRP=GRP_"M"
  1.  . I $P(X,U,6) S GRP=GRP_"W"
  1.  . S CODE1=$P(X,U,7)
  1.  . S CODE2=$P(X,U,8)
  1.  . S ARR(CNT)=CNT_"|0^"_NAME_"|4^"_GRP_"|34^"_CODE1_"|39^"_CODE2_"|49^"
  1.  . S ARR(CNT,0)=IIEN
  1.  . Q
  1. ILIST W !!,$E($T(IHDR),8,999),!,$E($T(ISEP),8,999)
  1. LIST S CNT=0 S SEL=""
  1.  F  S CNT=$O(ARR(CNT)) Q:'CNT  D  I $L(SEL) Q
  1.  . W !
  1.  . I (CNT#16)=0 D  I $L(SEL) Q
  1.  .. W "Enter 1-"_(CNT-1)_" or press <Enter> to see more: "
  1.  .. K % R %:$G(DTIME,60)
  1.  .. I $G(%)!(%?1."^") S SEL=% Q
  1.  .. W $C(13),?78,$C(13)
  1.  .. Q
  1.  . F PCE=1:1:$L(ARR(CNT),U) S X=$P(ARR(CNT),U,PCE) D
  1.  .. S Y=$P(X,"|"),Z=$P(X,"|",2)
  1.  .. W ?Z,Y
  1.  .. Q
  1.  . Q
  1.  I SEL="" W !,"Enter 1-"_$O(ARR(999),-1)_" or press '^' to quit: " R SEL:$G(DT,60) E  Q ""
  1.  I SEL?1."^"!(SEL="") Q ""
  1.  I '$D(ARR(SEL)) W "  ??" G ILIST
  1.  I $G(CFLG) W " (",$P($G(^VEN(7.91,ARR(SEL,0),0)),U),")" ; CONFIRM SELECTION
  1.  W !
  1.  Q ARR(SEL,0)
  1.  ;
  1. ATI(IIEN) ; EP-ASSOCIATED TEMPLATES FOR ITEMS
  1.  I '$O(^VEN(7.91,+$G(IIEN),2,0)) W !,"This item is not associated with any checklists or templates!" Q
  1.  N CKIEN,LIEN
  1.  W !,"This item is associated with the following checklists and PCC+ templates: "
  1.  S CKIEN=0 F  S CKIEN=$O(^VEN(7.91,IIEN,2,CKIEN)) Q:'CKIEN  D
  1.  . S LIEN=$P($G(^VEN(7.91,IIEN,2,CKIEN,0)),U) I 'LIEN Q
  1.  . D AT(LIEN)
  1.  . Q
  1.  Q
  1.  ; 
  1. AT(LIEN,MODE) ; EP-LIST TEMPLATES ASSOCIATED WITH A CHECKLIST
  1.  N NAME,STG,TIEN,I,%,TAB
  1.  S MODE=+$G(MODE)
  1.  S TAB=3 I MODE S TAB=0
  1.  S NAME=$P($G(^VEN(7.9,LIEN,0)),U) I '$L(NAME) Q
  1.  W !,?TAB W:MODE "PCC+ templates associated with " W NAME
  1.  S STG="",TIEN=0
  1.  S TAB=6 I MODE S TAB=3
  1.  F  S TIEN=$O(^VEN(7.41,TIEN)) Q:'TIEN  I $O(^VEN(7.41,TIEN,17,"B",LIEN,0)) S STG=STG_TIEN_U
  1.  I STG="" W !,?TAB,"No PCC+ templates are associated with this checklist!" Q
  1.  F I=1:1:($L(STG,U)-1) S TIEN=$P(STG,U,I) S %=$P($G(^VEN(7.41,TIEN,0)),U) I $L(%) W !,?TAB,%
  1.  Q
  1.  ; 
  1. IHDR ; #   ITEM                          GRP  CODE1     CODE2    
  1. ISEP ; --- ----------------------------- ---- --------- ---------
  1. CHDR ; #   NAME                           MAIL MERGE FLD PRE       POST
  1. CSEP ; --- ------------------------------ -------------- --------- ---------